求段代码，把汉语字/词 从多个txt文件中摘录出来。已解决

blackantt

1.关键字/词文件 key.txt 举例如下
cat key.txt
五
中国
一网打尽

2.语料库里有多个中文 txt 文件。

3.最终形成 result.txt 如下（最后的句中关键字用括号引起来，取关键字/词前一个句号与后一个句号之间的句子 ）
五. 我有[五]个朋友，还有更多女朋友。
五. 他说话一[五]一十。
.....
中国. 我是[中国]人。
中国. 说到[中国]，它是个美丽的国家，有十几亿人。
....
一网打尽. [一网打尽]是个成语。
一网打尽. 昨晚，小偷被[一网打尽]了。

laputa73

这么直接的要求,也不悬个赏啥的?

blackantt

laputa73 发表于 2018-09-20 08:01
这么直接的要求,也不悬个赏啥的?

   想用来给儿子复习成语。论坛悬赏功能吗？  不会用。

use Cwd;
use Data:umper;
use Encode;
use utf8;
my $dir = getcwd;

my $keyfile = $dir.'/key.txt';
my $targetpath = $dir.'/txt';
my $resultfile = $dir.'/result.txt';
print $keyfile;
open(RD,$keyfile);
my @keys;
while(<RD>{
        my $line = $_;
        $line =~ s/\n//isg;
        $line = decode('utf8',$line);
        push @keys,$line;
}
close RD;
print Dumper @keys;
opendir DIR,${targetpath};
my @filelist = readdir DIR;
shift @filelist;
shift @filelist;
open(WT,">".$resultfile);
shift @keys;
for my $onekey (@keys){
        my $num = 0;
        my $flag = 'no';
        print WT "result of ".$onekey.":\n";
        for my $one (@filelist){
                open(RDD,$targetpath.'\\'.$one);
                $/ = encode('utf8',"。";
                my @lines=<RDD>;
                for my $oneline (@lines){
                        $oneline = decode("utf8", $oneline);
                        my $newline = $oneline;
                                $newline =~ s/$onekey/(*$onekey*)/isg;
                        if ($newline ne $oneline){
                                print WT $onekey,"...",$newline."\n\n";
                                $num++;
                        }
                        if ($num ==20){
                                $flag = 'yes';
                                last;
                        }
                }
                if ($flag eq 'yes'){
                        last;
                }
                print $one;
        }
}

blackantt

论坛出错，发重了

523066680

em...

$line = decode('utf8',$line);
实际压缩包的文本是gbk的不是utf8  ....

只有水浒传是 utf8


建议：
找一个懂网页的，把这些文本转成HTML，关键词高亮粗体，会更直观。

523066680

1. =info
   
2.     Code by 523066680/vicyang
   
3.     2018-09
   
4. =cut
   
5. 
   
6. use utf8;
   
7. use Encode;
   
8. use File::Slurp;
   
9. use File::Basename qw/basename/;
   
10. STDOUT->autoflush(1);
    
11. 
    
12. # 读取关键字
    
13. my $raw = load( "key.txt" );
    
14. my @keys = split(/\r?\n/s, $raw );
    
15. printf "Words:\n\t%s\n", encode('gbk', join(",", @keys));
    
16. 
    
17. # 读取文本
    
18. my $fold = "./txt";
    
19. my @files = glob "${fold}/*.txt";
    
20. my %book;
    
21. grep { $book{ $_ } = load( $_ ) } ( sort @files );
    
22. 
    
23. print "\n";
    
24. 
    
25. open my $fh, ">:raw:crlf", "result.txt";
    
26. select $fh;
    
27. 
    
28. my @arr;
    
29. my $tmp;
    
30. for my $k ( @keys )
    
31. {
    
32.     printf "%s\n", encode('gbk', $k);
    
33.     for my $bk ( sort keys %book )
    
34.     {
    
35.         @arr = ();
    
36.         printf "    %s:\n", basename($bk);
    
37.         $tmp = $book{ $bk };
    
38.         grep { push @arr, ( /([^。！!？]*$k[^。！!？]*)/g ) } split( /\r?\n/, $tmp );
    
39.         grep { s/$k/[$k]/ } @arr;
    
40.         grep {  printf "        %s\n", encode('gbk', $_) } @arr;
    
41.     }
    
42. }
    
43. 
    
44. close $fh;
    
45. 
    
46. sub load
    
47. {
    
48.     my $file = shift;
    
49.     my $s = read_file($file, {binmode => ":raw"} );
    
50.     if ( $s eq encode('utf8', decode('utf8', $s)) ) {
    
51.         $s =~s/^\xEF\xBB\xBF//;
    
52.         return decode('utf8', $s);
    
53.     } else {
    
54.         return decode('gbk', $s);
    
55.     }
    
56. }
    
57. 
    

复制代码

输出结果在Result.txt


部分结果转成论坛格式：

万不得已
    1.txt:
        ...万不得已
        1、他不会向你借钱,除非万不得已
        2、不到万不得已，我是不会这样做的
        3、王荣病到万不得已的时候,才肯吃药、打针
        4、一般说，老虎并非天生就吃人，只是万不得已而为之
        5、这是他最珍爱的传家之宝,不到万不得已,是绝不肯轻易变卖的
        6、不在万不得已的情况下，绝对不要显灵，特别是不要为了虚荣
    2.txt:
    3.txt:
    水浒传.txt:
侃侃而谈
    1.txt:
        ...侃侃而谈
        1、畅开心扉是为了虚荣，为了侃侃而谈，为了得到别人的信赖，为了交换秘密
        2、勇气是能站起来侃侃而谈
        3、他们俩又是探头偷觑，又是评短论长，又是侃侃而谈，简直就象两个老知交
        4、一位称职的外交人员，定能在重要场合为国家利益侃侃而谈
        5、想不到一向慌乱的他，在会议上陈述理由时，竟能侃侃而谈
    2.txt:
    3.txt:
        1、他对这件事情侃侃而谈时，常常表现出老成持重的样子
    水浒传.txt:
满目凄凉
    1.txt:
    2.txt:
        满目凄凉
        1、富饶的鱼米之乡被鬼子糟踏得满目凄凉
        2、走进山沟,满目凄凉,到处都是残破不堪的景象
        3、他踏上荒废多年的老城墙,满目凄凉
        4、吹散一瓣瓣温婉桃花，满目凄凉，归去路，泪界落腮，心，被一根无名的弦触动了，遂痛到不能自己
        5、一个窗架上突出一根生锈的铁棒,真是满目凄凉.6、满目凄凉的惨状
    3.txt:
    水浒传.txt:

花蝴蝶456789

回复 1# blackantt 求解一下~     if ($title[1] =!  不包含某个txt中的内容，怎么写呢？

blackantt

回复 7# 花蝴蝶456789
    请教下6楼大侠。 程序是别人写的，我只会用。

blackantt

523066680 发表于 2018-09-21 13:16
输出结果在Result.txt

谢谢，记 录下 ppm 安装过程，备忘

C:\Users\dengz\Desktop\perl-word\perl>perl re.pl
Can't locate File/Slurp.pm in @INC (you may need to install the File::Slurp module) (@INC contains: C:/Perl64/site/lib C:/Perl64/lib) at re.pl line 8.
BEGIN failed--compilation **rted at re.pl line 8.

-----------------------


先安装activeperl到 c:\Perl64
然后在dos下执行
ppm search file-slurp
ppm install file-slurp
----------------如果没有ppm 或者ppm要设代理的话。 用cpan装
cpan File::Slurp----------------------------最新的activeperl没有ppm，干脆用 StrawberryPerl (cpanm File::Slurp)

草莓perl的优点完全开源，自带cpanm。

安装注意事项，

默认安装后会把这些路径添加到环境变量Path的末尾。

C:StrawberryPerlcbin;  #存放的是c编译器，用于安装c写的perl模块

C:StrawberryPerlperlsitebin; #模块的可执行命令存放的地方，如mojo命令等

C:StrawberryPerlperlbin;#存放perl.exe cpanm.bat等命令地方

花蝴蝶456789

回复 6# 523066680

大神~请问一下哈，我想让$title[4]不包含以key命名的txt文件里所有的内容，这段代码怎么写呢。（这个TXT里的内容，都是一个一个的关键词，每一个关键词占一行。这样的格式）需求：
while(<> {
  chomp;
  my @title = split/\t/;  

    if ($title[4] =! /不包含另一个txt里的所有内容/) {  
     print HD "$_\n";

     }

}


把title4中不包含的内容，输出在HD文件中

这段怎么写呢？