view release on metacpan or  search on metacpan

examples/Tkwic.perl  view on Meta::CPAN

sub clear_query {
    my ($self) = @_;

    my $entry_widget = $self->{current_query_entry};
    $self->set_query($entry_widget, '');
    $entry_widget->focus();
};

sub copy_query {
    my ($self, $query_text) = @_;

    my $entry_widget = $self->{current_query_entry};
    $self->set_query($entry_widget, $query_text);
    $entry_widget->focus();
}

sub get_macros_from_file {
    my ($self, $filename) = @_;
    my @macros;

    if (open FILE, $filename) {
        my $state = 'none';

        while (<FILE>) {
            # Strip comments.  Lines that contain a quoted sharp are not
            # handled, so don't put comments into these lines.
            s/\#.*$// if !/([\'\"]).*\#.*\1/o;
            # Strip leading and trailing spaces.
            s/^\s*//o;
            s/\s*$//o;
            # Empty lines are skipped.
            next if !$_;
            if ($state eq 'macro') {
                # The end of the macro is reached if the line ends with a
                # semicolon.
                if (/;$/o) {
                    chop;
                    $state = 'none';
                }
                push(@{$macros[-1]->{body}}, $_) if $_;
            } else {
                my @list = /MACRO\s+(.*)\((.*)\)/o;
                if (@list) {
                    push @macros, {name => $list[0], body => []};
                    $state = 'macro';
                } else {
                    my $p = basename($0);
                    print STDERR "$p:$filename:$.: Syntax error near to `$_´\n";
                }
            }
        }
        close FILE;
    } else {
        my $p = basename($0);
        print STDERR "$p:$filename: Cannot open file\n";
    }
    return \@macros;
}

sub update_history_menu {
    my ($self) = @_;
    my ($menu, $history, $label);

    $menu = $self->{history_menu};
    $history = $self->{query_history};
    $menu->delete(1, 'end');
    foreach my $query (@$history) {
        $label = substr($query, 0, 40);
        $label =~ s/\n/ /go; 
        $menu->add('command', -label => $label,
                    -command => [\&copy_query, $self, $query]);
    } 
}

sub create_query_area {
    my ($self) = @_;

    my $main_window = $self->{main_window};
    my $vbox = $main_window->Frame(-relief => 'groove', -borderwidth => 2);
    my $popup = $self->{query_popup} =
        $vbox->Menu(-menuitems => [['command' => "Clear query",
                                    -command => [\&clear_query, $self]]],
                    -tearoff => 0);
    my $query_entry;
    for (my $i = 0; $i < $NumberOfQueryEntries; $i++) {
        if ($UseTextWidget) {
            my $scrolled = $vbox->Scrolled('Text', -scrollbars => 'osoe',
                                           -height => $QueryEntryHeight,
                                           -wrap => 'word');
            $query_entry = $scrolled->Subwidget('scrolled');
            $query_entry->tagConfigure('argument', -foreground => $ArgumentColor);
            $query_entry->tagConfigure('info', -foreground => $InfoColor);
            $query_entry->bind('Tk::Text', '<3>', '');
            $scrolled->pack(-fill => 'x', -expand => 1);
        } else {
            $query_entry = $vbox->Entry();
            $query_entry->pack(-fill => 'x', -expand => 1);
        }
        $query_entry->bind('<FocusIn>', [ \&query_focus_in, $self, $i ]);
        $query_entry->bind('<Button-3>',
                           sub { $popup->Popup(-popover => 'cursor', -popanchor => 'nw'); });
        $self->{query_entry}[$i] = $query_entry;
    }
    $self->{query_entry}[0]->focus();
    my $hbox = $vbox->Frame();
    my $history_button =
        $hbox->Menubutton(-text => "History", -indicatoron => 1,
                          -relief => 'raised', -pady => 5);
    $self->{history_menu} = $history_button->menu;
    my $execute_query_button = $hbox->Button(-text => "Start query",
                                          -command => [\&execute_query, $self]);
    $history_button->grid($execute_query_button, -sticky => 'ew');
    $hbox->gridColumnconfigure(1, -weight => 1);
    $hbox->pack(-fill => 'x', -expand => 1);
    return $vbox;
}

sub query_focus_in {
    my ($widget, $self, $n) = @_;

examples/Tkwic.perl  view on Meta::CPAN

                                      -buttons => [ $continue, $cancel ],
                                      -default_button => $cancel);
    my $answer = $dialog->Show();
    $dialog->destroy();
    return ($answer eq $continue);
}

sub get_frequency {
    my ($self) = @_;

    $self->busy();
    my $hlist = $self->{freq_list};
    my $corpus = $self->{corpus};
    my $query = $self->get_query();
    if ($query) {
        my $status = cqi_query($corpus, "A", $query);
        if ($status == $CWB::CQI::STATUS_OK) {
            my $subcorpus = "$corpus:A";
            my $size = cqi_subcorpus_size($subcorpus);
            my $ok = 1;
            if ($size > $FreqDistribDialog_MaxNumberOfResults) {
                $ok = $self->freq_size_warning($size);
            }
            if ($ok) {
                $hlist->delete('all');
                my $type_number = $self->{type_number};
                if ($type_number == 0) {
                    $ok = $self->get_frequency_single($corpus, $subcorpus);
                } elsif ($type_number == 1) {
                    $ok = $self->get_frequency_pair($corpus, $subcorpus);
                } elsif ($type_number == 2) {
                    $ok = $self->get_frequency_grouped($corpus, $subcorpus);
                }
                cqi_drop_subcorpus($subcorpus);
                if ($ok) {
                    $self->set_status_message("Done");
                }
            }
        } else {
            $self->set_status_message("Query failed", 'ERROR');
        }
    } else {
        $self->set_status_message("Cannot execute empty query", 'ERROR');
    }
    $self->unbusy();
};

sub set_frequency_type {
    my ($self, $type_number) = @_;

    my $state;
    if ($type_number == 0) {
        $state = 'disabled';
    } else {
        $state = 'normal';
    }
    $self->{field2_menu}->configure(-state => $state);
    $self->{attr2_menu}->configure(-state => $state);
}

sub update_freq_dialog {
    my ($self) = @_;
    my ($freq_dialog, $attributes, $default_attribute, $attribute);

    $attributes = $self->{positional_attributes};
    $default_attribute = $attributes->[0];

    $freq_dialog = $self->{freq_dialog};
    if (Tk::Exists($freq_dialog)) {
        # If the corpus doesn't support the currently selected attributes the
        # option menus are reset.
        $attribute = $self->{attr1};
        if (!grep {$_ eq $attribute} @$attributes) {
            $self->{attr1} = $default_attribute;
        }
        $attribute = $self->{attr2};
        if (!grep {$_ eq $attribute} @$attributes) {
            $self->{attr2} = $default_attribute;
        }
        $self->{attr1_menu}->configure(-options => $attributes);
        $self->{attr2_menu}->configure(-options => $attributes);
    }
}

sub create_freq_dialog {
    my ($self) = @_;
    my ($attributes, $default_attribute);

    $attributes = $self->{positional_attributes};
    $default_attribute = $attributes->[0];

    my $main_window = $self->{main_window};
    my $dialog = $self->{freq_dialog} = $main_window->Toplevel();
    $dialog->title("Frequency distributions");

    my $box = $dialog->Frame(-relief => 'groove', -borderwidth => 2);
    my $type_label = $box->Label(-text => "Type:");
    my $display_var = "Single";
    $self->{type_number} = 0;
    my $type_menu = $box->Optionmenu(-options => [["Single", 0],
                                                  ["Pair", 1],
                                                  ["Grouped", 2]],
                                     -textvariable => \$display_var,
                                     -variable => \$self->{type_number},
                                     -command => [\&set_frequency_type,
                                                  $self]);
    $self->{cutoff_freq} = $DefaultCutoff;
    my $cutoff_label = $box->Label(-text => "Cut off:");
    my $cutoff_entry = $box->Entry(-textvariable => \$self->{cutoff_freq},
                                   -width => 5,
                                   -justify => 'right');
    $self->{cutoff_entry} = $cutoff_entry;
    $type_label->grid($type_menu, $cutoff_label, $cutoff_entry,
                      -sticky => 'w');

    $self->{field1} = "match";
    $self->{attr1} = $default_attribute;
    my $field1_label = $box->Label(-text => "Field 1:");
    my $field1_menu = $box->Optionmenu(-options => ["match",
                                                    "target",
                                                    "matchend"],
                                       -variable => \$self->{field1});
    my $attr1_label = $box->Label(-text => "Attribute 1:");
    my $attr1_menu = $box->Optionmenu(-options => $attributes,
                                      -variable => \$self->{attr1});
    $field1_label->grid($field1_menu, $attr1_label, $attr1_menu, -sticky => 'w');
    $self->{field1_menu} = $field1_menu;
    $self->{attr1_menu} = $attr1_menu;

    $self->{field2} = "matchend";
    $self->{attr2} = $default_attribute;
    my $field2_label = $box->Label(-text => "Field 2:");
    my $field2_menu = $box->Optionmenu(-options => ["match",
                                                    "target",
                                                    "matchend"],
                                       -variable => \$self->{field2});
    my $attr2_label = $box->Label(-text => "Attribute 2:");
    my @list;
    my $attr2_menu = $box->Optionmenu(-options => $attributes,
                                      -variable => \$self->{attr2});
    $field2_label->grid($field2_menu, $attr2_label, $attr2_menu, -sticky => 'w');
    $self->{field2_menu} = $field2_menu;
    $self->{attr2_menu} = $attr2_menu;

    my $start = $dialog->Button(-text => "Start",
                                -command => [\&get_frequency, $self]);

    my $scrolled = $dialog->Scrolled('HList', -scrollbars => 'osoe',
                                     -exportselection => 0,
                                     -itemtype => 'text',
                                     -width => $FreqDistribDialog_ListWidth,
                                     -height => $FreqDistribDialog_ListHeight,
                                     -header => 1,
                                     -columns => 3);
    my $hlist = $self->{freq_list} = $scrolled->Subwidget('scrolled');
    $hlist->headerCreate(0, -text => "Field 1");
    $hlist->headerCreate(1, -text => "Field 2");
    $hlist->headerCreate(2, -text => "Freq.");
    $hlist->columnWidth(2, -char => 7);
    my $bg = $hlist->cget('-background');
    $self->{freq_list_style_freq} =
      $hlist->ItemStyle('text', -background => $bg, -foreground => $InfoColor,
                        -anchor => 'e');

    my $close = $dialog->Button(-text => "Close",
                                -command => sub { $dialog->destroy(); });

    $box->grid(-sticky => 'ew');
    $start->grid(-sticky => 'ew');
    $scrolled->grid(-sticky => 'nsew');
    $close->grid(-sticky => 'ew');
    $dialog->gridColumnconfigure(0, -weight => 1);
    $dialog->gridRowconfigure(2, -weight => 1);

    $self->set_frequency_type(0);

    return $dialog;
}

sub update_tag_dialog {
    my ($self) = @_;
    my ($tag_dialog, $corpus, $hlist, $n, @tags, $id, $freq);

    $corpus = $self->{corpus};

    $tag_dialog = $self->{tag_dialog};
    if (Tk::Exists($tag_dialog)) {
        $hlist = $self->{tag_list};
        $hlist->delete('all');
        $self->{tag_example}->configure(-text => '');

        if ($self->has_positional_attribute('pos')) {
            $n = cqi_lexicon_size("$corpus.pos");
            if ($n > 0) {
                @tags = cqi_id2str("$corpus.pos", 0..$n-1);
                @tags = sort @tags;
                foreach (@tags) {
                    $id  = cqi_str2id("$corpus.pos", $_);
                    $freq = cqi_id2freq("$corpus.pos", $id);
                    my $e = $hlist->addchild('', -data => ''); # Example
                    $hlist->itemCreate($e, 0, -text => $_);    # Tag
                    $hlist->itemCreate($e, 1, -text => "($freq)"); # Comment
                }
            }
        }
    }
}

sub copy_tag_example {
    my ($self, $e) = @_;

    my $hlist = $self->{tag_list};
    my $example = $hlist->info('data', $e);
    $self->{tag_example}->configure(-text => $example);
}

sub create_tag_dialog {
    my ($self) = @_;

    my $main_window = $self->{main_window};
    my $dialog = $self->{tag_dialog} = $main_window->Toplevel();
    $dialog->title("Tags");
    my $scrolled = $dialog->Scrolled('HList', -scrollbars => 'osoe',
                                     -exportselection => 0,
                                     -itemtype => 'text',
                                     -columns => 2,
                                     -width => $TagHelpWidgetWidth,
                                     -height => $TagHelpWidgetHeight,
                                     -browsecmd => [\&copy_tag_example,
                                                    $self]);
    $self->{tag_list} = $scrolled->Subwidget('scrolled');
    my $vbox = $dialog->Frame();
    my $example_label = $vbox->Label(-text => "Examples:");
    my $example = $vbox->Label(-relief => 'sunken', -anchor => 'w',
                               -background => $BackgroundColor,
                               -foreground => $InfoColor);
    $self->{tag_example} = $example;
    $example_label->grid($example, -sticky => 'ew');
    $vbox->gridColumnconfigure(1, -weight => 1);
    my $close = $dialog->Button(-text => 'Close',