src/jaxam

   1 #! /usr/bin/perl
   2 #
   3 # $Id$
   4
   5
   6 use strict;
   7 use warnings;
   8 require Term::ReadKey;
   9 require Tree::Binary::Search;
  10 use Getopt::Long;
  11 require Time::Piece::ISO;
  12 require POSIX;
  13
  14
  15 our $opt_debug=1;
  16 my $opt_dict=$ENV{"HOME"}."/priv/japan-lang/jfe_1-9.csv";
  17 my $opt_log=$opt_dict.".log";
  18
  19 $Getopt::Long::ignorecase=0;
  20 $Getopt::Long::bundling=1;
  21 die if !GetOptions(
  22                 "d|debug+"=>\$opt_debug,
  23                 "c|dict=s"=>\$opt_dict,
  24                 "l|log=s" =>\$opt_log,
  25                 );
  26
  27 my $T;
  28
  29 sub schedule($)
  30 {
  31         my($r)=@_;
  32
  33         my $sum=0;
  34         for my $result (@{$r->{"result"}}) {
  35                 my $age=time()-$result->{"time"};
  36                 $age=0 if $age<0;
  37                 # $age:   0..  big importance
  38                 # $age: big..small importance
  39                 # $ok: 0..mistake
  40                 # $ok: 1..correct
  41                 # $sum:   big..far
  42                 # $sum: small..soon
  43                 # 1/log(2+$age): big..  big importance
  44                 # 1/log(2+$age):   0..small importance
  45                 $sum+=1/log(2+$age)*($result->{"ok"}?+1:-1);
  46                 }
  47         my $arr=[];
  48         if ($T->exists($sum)) {
  49                 $arr=$T->select($sum)->{"arr"};
  50                 $T->delete($sum);
  51         }
  52         splice @$arr,int(rand(@$arr+1)),0,$r;
  53         $T->insert($sum=>{"key"=>$sum,"arr"=>$arr});
  54         print STDERR "; schedule=$sum" if $opt_debug;
  55 }
  56
  57 sub best()
  58 {
  59         return if $T->isEmpty();
  60         my $min=$T->min()->{"key"};
  61         my $arr=$T->select($min)->{"arr"};
  62         $T->delete($min);
  63         my $r=shift @$arr;
  64         $T->insert($min=>{"key"=>$min,"arr"=>$arr}) if @$arr;
  65         print STDERR "min=$min\n" if $opt_debug;
  66         return $r;
  67 }
  68
  69 sub identify($)
  70 {
  71         my($r)=@_;
  72
  73         return join " ",map(($r->{$_}||"-"),qw(
  74                         written
  75                         phonetic
  76                         ));
  77 }
  78
  79 sub result($$)
  80 {
  81         my($r,$ok)=@_;
  82
  83         local *LOG_APPEND;
  84         open LOG_APPEND,">>".$opt_log or die "append \"$opt_log\": $!";
  85         print LOG_APPEND Time::Piece::ISO::localtime().POSIX::strftime("%z",localtime())." ok=$ok: ".identify($r)."\n";
  86         close LOG_APPEND or die "close \"$opt_log\": $!";
  87
  88         push @{$r->{"result"}},{
  89                 "time"=>time(),
  90                 "ok"=>$ok,
  91                 };
  92         schedule $r;
  93 }
  94
  95 my @R;
  96 my %keyword;
  97 $T=Tree::Binary::Search->new();
  98 $T->useNumericComparison();
  99 local *DICT;
 100 open DICT,$opt_dict or die "open \"$opt_dict\": $!";
 101 while (<DICT>) {
 102         chomp;
 103         my $r;
 104         my $rest;
 105         (
 106                 $r->{"written"},
 107                 $r->{"phonetic"},
 108                 $r->{"meaning"},
 109                 $r->{"category"},
 110                 $r->{"learned"},
 111                 $rest,
 112                 )=split /\t/;
 113         next if $r->{"written"} eq "";
 114         die "Excessive argument: $rest" if defined $rest;
 115         while ($r->{"meaning"}=~s/\s*<([-\w]+)>\s*//) {
 116                 my $keyword=$1;
 117                 $r->{"meaning_keyword"}{$keyword}=1;
 118                 $keyword{$keyword}=1;
 119                 }
 120         $r->{"meaning"}!~/[<>]/ or warn "Meaning constains invalid characters: ".$r->{"meaning"};
 121         push @R,$r;
 122 }
 123 close DICT or die "close \"$opt_dict\": $!";
 124
 125 my %identify=map((identify($_)=>$_),@R);
 126
 127 local *LOG_READ;
 128 if (!open LOG_READ,$opt_log) {
 129         warn "open \"$opt_log\": $!";
 130 } else {
 131         while (<LOG_READ>) {
 132                 chomp;
 133                 # 2002-04-25T21:17:52+0900 ok=1: identify($r)
 134                 my($year, $month, $day,   $hour,  $minute,$second,$zonepm,$zonehour,$zoneminute,$ok,$identify)=
 135                 /^(\d{4})-(\d{1,2})-(\d{2})T(\d{2}):(\d{2}):(\d{2})([+-])(\d{2})(\d{2}) ok=(\d+): (.+)$/
 136                                 or do { warn "Unrecognized line: $_\n"; next; };
 137                 $year-=1900;
 138                 $month--;
 139                 my $localtime=POSIX::mktime($second,$minute,$hour,$day,$month,$year);
 140                 $localtime or do { warn "Unparsable time at line: $_\n"; next; };
 141                 my $gmtime=$localtime-($zonepm."1")*($zonehour*60+$zoneminute);
 142                 my $r=$identify{$identify}
 143                                 or do { warn "Word not found from line: $_\n"; next; };
 144                 push @{$r->{"result"}},{
 145                         "time"=>$gmtime,
 146                         "ok"=>$ok,
 147                         };
 148         }
 149         close LOG_READ or die "close \"$opt_log\": $!";
 150 }
 151
 152 for my $r (@R) {
 153         local $opt_debug=0 if $opt_debug<2;
 154         print STDERR $r->{"phonetic"}."\t".$r->{"meaning"} if $opt_debug;
 155         schedule $r;
 156         print STDERR "\n" if $opt_debug;
 157 }
 158
 159 my %exam=(
 160         "phonetic"=>"meaning",
 161         "meaning"=>"phonetic",
 162         );
 163 my @exam=keys(%exam);
 164 my $r_last;
 165 my $exam_from_last;
 166 for (;;) {
 167         my $r=best();
 168         # Do not change $exam_from if $r remained the same:
 169         my $exam_from=$exam_from_last;
 170         if (!$r_last || $r ne $r_last) {
 171                 $exam_from=$exam[int rand @exam];
 172                 }
 173         my $exam_to  =$exam{$exam_from};
 174         print $r->{$exam_from}.": ";
 175         my $got=<STDIN>;
 176         chomp $got;
 177         my $want=$r->{$exam_to};
 178         print "-------> $want\n";
 179         (my $got_chk =lc $got )=~s/\s//g;
 180         (my $want_chk=lc $want)=~s/\s//g;
 181         $got_chk=~s/\bto\b//g;
 182         $want_chk=~s/\bto\b//g;
 183         $want_chk=~s/[(][^)]*[)]//g;
 184         warn "Parenthesis ('(',')') not supported in the user input: $got\n" if $got=~/[()]/;
 185         warn "Comma (',') not well supported in the user input: $got\n" if $got=~/,/;
 186         my $ok;
 187         $ok=1 if $got_chk eq $want_chk; # incl. commas
 188         for (split /,/,$want_chk) {
 189                 $ok=1 if $got_chk eq $_;
 190         }
 191         if (!$ok) {
 192                 if ($exam_to eq "meaning" && $got=~/\S/ && $want=~/\Q$got\E/) {
 193                         my $key;
 194                         do {
 195                                 print STDERR "Is your answer correct? [y/n] ";
 196                                 sub restore
 197                                 {
 198                                         Term::ReadKey::ReadMode(0);
 199                                 }
 200                                 local $SIG{"__DIE__"}=\&restore;
 201                                 Term::ReadKey::ReadMode(4);
 202                                 $key=Term::ReadKey::ReadKey(0);
 203                                 print STDERR "\n";      # no echo
 204                                 restore();
 205                                 $ok=1 if $key eq "y";
 206                                 $ok=0 if $key eq "n";
 207                         } while (!defined $ok);
 208                 }
 209         }
 210         $ok||=0;
 211         print STDERR "result: ".($ok ? "ok" : "WRONG");
 212         result($r,$ok);
 213         print "\n";
 214         $r_last=$r;
 215         $exam_from_last=$exam_from;
 216 }