ktouch/extras/training-gen/perl/ktouch-gen.pl

   1 #!/usr/bin/perl -w --strict
   2
   3 # default values
   4 $length_of_line = 60;
   5 $number_of_line = 30;
   6
   7
   8 # genword( accumulated, core )
   9 # This function will generate a random sequens of character
  10 # containing only characters from accum or core and all words
  11 # generated will contain at lest on character from core
  12 sub genword
  13 {
  14     (my $accum, my $core) = @_;
  15
  16     my $all=$accum.$core;
  17     my $res="";
  18
  19     for(my $i=0;$i<=rand(5);$i++)
  20     {
  21         my $ran_pos=int(rand(length($all)));
  22         $res=$res.substr($all,$ran_pos,1);
  23     }
  24
  25     # check if we have generated a walid word, containig some characters from $core
  26     if ($res =~ m/[$core]/)
  27     {
  28         return $res;
  29     }
  30     else
  31     {
  32         return genword($accum,$core);
  33     }
  34 }
  35
  36 # This function will return a list of words containing only characters from
  37 # accum or core. And all words will contain at lest on echaracter from core.
  38 # If we can't find enough words, we will use genword to generate enough words
  39 # to fill the list.
  40 sub genlist
  41 {
  42     ($accum, $core) = @_;
  43     my @res;
  44
  45     my $all=$accum.$core;
  46
  47
  48     #print "$core\n";
  49
  50     foreach(@word_list)
  51     {
  52         chomp($_);
  53         if (m/[$core]/ && m/^[($all)][$all]*$/)
  54         {
  55             push @res,$_;
  56         }
  57     }
  58
  59     for(my $i=@res;$i<30;$i++)
  60     {
  61         push @res,genword($accum,$core);
  62     }
  63
  64     return @res;
  65 }
  66
  67
  68 # Genlevel will generate a level
  69 sub genlevel
  70 {
  71     ($accum, $core) = @_;
  72     my $res = "";
  73     my @list = genlist($accum,$core);
  74     my $max_lines = $number_of_line;
  75     my $max_length = $length_of_line;
  76     while($max_lines >0)
  77     {
  78         my $tmp=$list[rand(@list)-1];
  79         $res = $res.$tmp; # first word on line should not have space
  80         while($max_length >0)
  81         {
  82             my $tmp=$list[rand(@list)-1];
  83             $res = $res." ".$tmp;
  84             $max_length = $max_length - (length($tmp) + 1); # +1 is for counting one extra space for each word
  85         }
  86         $res = $res."\n";
  87         $max_length = $length_of_line;
  88         $max_lines = $max_lines - 1;
  89     }
  90     return $res;
  91 }
  92
  93 sub rrr
  94 {
  95     print ".";
  96     s/\\/\\\\/g; #remove escape character...
  97     s/-/\\-/g; #remove any - since this will mean range
  98     s/ //g;
  99     return $_;
 100 }
 101
 102 sub heading
 103 {
 104     return
 105         "######################################################################\n".
 106         "##\n".
 107         "# KTouch training file generated ".localtime(time())."\n".
 108         "#\n".
 109         "# Perl Script written by Steinar Theigmann & Håvard Frøiland.\n".
 110         "#\n";
 111 }
 112
 113 sub usage
 114 {
 115     return
 116         "\n".
 117         "usage: ktouch-gen config_file\n".
 118         "   Example: ./ktouch-gen english-conf < english-word-file\n".
 119         "\n";
 120 }
 121
 122 # --------------------- START ----------------------------
 123
 124 if(@ARGV == 0) # exit if there is no config_file specified
 125 {
 126     die usage;
 127 }
 128
 129 open(CONFIG,$ARGV[0]) # First argument should be config file
 130     or die "\ nCan't find config_file: $ARGV[0]\n\n";
 131
 132 # Read in all elements in config file
 133 while (<CONFIG>)
 134 {
 135     chomp($_);
 136
 137     if(s/length\-of\-line//)
 138     {
 139         $length_of_line = $_;
 140     }
 141     elsif(s/number\-of\-line//)
 142     {
 143         $number_of_line = $_;
 144     }
 145     elsif($_) # Add to config if not empty
 146     {
 147         push @config,$_;
 148     }
 149 }
 150
 151 #foreach(@config)
 152 #{
 153 #    print "$_\n";
 154 #}
 155 #exit 0;
 156
 157 # Read in all words
 158 while (<STDIN>)
 159 {
 160     chomp($_);
 161     if(length($_)>0)
 162     {
 163         push @word_list, $_;
 164     }
 165 }
 166
 167 print heading;
 168
 169 $accum="";
 170 $count=0;
 171 foreach(@config)
 172 {
 173     $count++;
 174     print "# Level $count\n";
 175     print "$_\n";
 176     print genlevel($accum,$_);
 177     $accum=$accum.$_;
 178     print "\n\n";
 179 }
 180