view release on metacpan or  search on metacpan

lib/QRCode/Encoder/Matrix.pm  view on Meta::CPAN

   my $matrix = $data->{matrix};
   my $ecstart = $data->{eside_size} - 4 - 7 - 4;
   for my $i (4 .. 9) {
      for my $j ($ecstart .. ($ecstart + 2)) {
         $matrix->[$i][$j] = $matrix->[$j][$i] = 0x32;
      }
   }

   return $data;
}

sub add_timing ($data) {
   my $matrix = $data->{matrix};
   my $es = $data->{eside_size};
   for my $i (12 .. ($es - 4 - 8 - 1)) {  
      $matrix->[$i][10] = $matrix->[10][$i] = 0x35 ^ ($i & 1);
   }
   return $data;
}

sub try_add_alignment_pattern ($data, $x, $y) {
   state $shape = [
      [  0x31, 0x31, 0x31, 0x31, 0x31 ],
      [  0x31, 0x30, 0x30, 0x30, 0x31 ],
      [  0x31, 0x30, 0x31, 0x30, 0x31 ],
      [  0x31, 0x30, 0x30, 0x30, 0x31 ],
      [  0x31, 0x31, 0x31, 0x31, 0x31 ],
   ];
   $x += 4; # offset by quiet zone
   $y += 4; # offset by quiet zone
   my $matrix = $data->{matrix};
   return if $matrix->[$y][$x] < 0x34
      || $matrix->[$y][$x + 4] < 0x34
      || $matrix->[$y + 4][$x] < 0x34;
   for my $i (0 .. 4) {
      for my $j (0 .. 4) {
         $matrix->[$y + $i][$x + $j] = $shape->[$i][$j];
      }
   }
}

sub add_alignments ($data) {
   my @offset = qrspec_alignment_patterns($data->{version});
   for my $y_center (@offset) {
      for my $x_center (@offset) {
         try_add_alignment_pattern($data, $x_center - 2, $y_center - 2);
      }
   }
   return $data;
}

sub bits_iterator ($data) {
   my $n_expanded = length($data->{expanded});
   my $rem = $data->{remainder};
   my $i = 0;
   my @queue;
   return sub {
      if (! @queue) {
         if ($i < $n_expanded) {
            push @queue, split m{}mxs, unpack 'B*', substr($data->{expanded}, $i++, 1);
         }
         else {
            push @queue, ('0') x $rem;
            $rem = 0;
         }
      }
      return shift(@queue);
   };
}

sub add_codewords ($data) {
   my $it = bits_iterator($data);
   my $matrix = $data->{matrix};
   my $side_size = $data->{side_size};

   # start from a fake position that would be the last bit of a
   # hypothetical "-1" codeword
   my $x = $side_size - 2;
   my $y = $side_size;
   my $left = 1;
   my $d = -1; # direction
   while (defined(my $bit = $it->())) {
      while ('necessary') {
         if ($x % 2 == $left) {
            ++$x;
            $y += $d;
         }
         else {
            --$x;
         }
         if ($d < 0 && $y < 0) { # reset condition
            $x -= 2;
            $y = 0;
            $d = 1;
         }
         elsif ($d > 0 && $y >= $side_size) { # other reset condition
            $x -= 2;
            $y = $side_size - 1;
            $d = -1;
         }
         if ($x == 6) { # left timing column, skip a column entirely
            $x = 5;
            $left = 0;
         }
         last if $matrix->[$y + 4][$x + 4] > 0x37;  # found suitable position
      }
      $matrix->[$y + 4][$x + 4] = $bit ? 0x37 : 0x36;
   }
   return $data;
}

sub evaluate_matrix ($matrix) {
   return 0
      + evaluate_matrix_adjacents_and_11311($matrix)
      + evaluate_matrix_blocks($matrix)
      + evaluate_matrix_proportion($matrix);
}

sub __row ($matrix, $i) {
   my $max_idx = $matrix->[0]->$#* - 4;
   join('', map { $matrix->[$i + 4][$_] & 0x01 ? 1 : 0 } 4 .. $max_idx);
}

sub __col ($matrix, $i) {
   my $max_idx = $matrix->[0]->$#* - 4;
   join('', map { $matrix->[$_][$i + 4] & 0x01 ? 1 : 0 } 4 .. $max_idx);
}

sub evaluate_matrix_adjacents_and_11311 ($matrix) {
   my $side_size = $matrix->[0]->@* - 8;
   my $penalty = 0;
   my $penalty2 = 0;
   for my $i (0 .. ($side_size - 1)) {
      for my $seq (__row($matrix, $i), __col($matrix, $i)) {

         # adjacences
         my @contributions =
            map  { $_ -  2 }
            grep { $_ >= 5 }
            map  { length  }
            split m{(0+)}mxs, $seq;
         $penalty += sum(@contributions) if @contributions;

         # 000011311 | 113110000
         my @matches = $seq =~ m{
            (
                 (?: (?<=0000) 1011101           )  # look behind...
               | (?:           1011101 (?=0000)  )  # or look ahead
            )
         }gmxs;
         $penalty2 += 40 * scalar(@matches);

      }
   }
   return $penalty + $penalty2;
}

sub evaluate_matrix_blocks ($matrix) {
   my $side_size = $matrix->[0]->@* - 8;
   my $penalty = 0;
   for my $i (0 .. ($side_size - 2)) {
      for my $j (0 .. ($side_size - 2)) {
         my $count = 0;
         for my $offset ([0, 0], [0, 1], [1, 0], [1, 1]) {
            my ($oi, $oj) = $offset->@*;
            $count++ if $matrix->[$i + $oi + 4][$j + $oj + 4] & 1;
         }
         $penalty += 3 if ($count == 0) || ($count == 4);
      }
   }
   return $penalty;
}

sub evaluate_matrix_proportion ($matrix) {
   my $count = sum( map { map { $_ & 0x1 ? 1 : 0 } $_->@* } $matrix->@* );
   my $side_size = $matrix->[0]->@* - 8;
   my $total = $side_size * $side_size;
   my $percentage = 100 * $count / $total;
   my $deviation = abs($percentage - 50);
   my $penalty = 10 * int($deviation / 5);
   return $penalty;
}

sub masked_matrix ($data, $mask_id) {
   state $mask_for = {
      0 => sub ($i, $j) { (($i + $j) % 2) == 0 },
      1 => sub ($i, $j) { ($i % 2) == 0 },
      2 => sub ($i, $j) { ($j % 3) == 0 },
      3 => sub ($i, $j) { (($i + $j) % 3) == 0 },
      4 => sub ($i, $j) { ((int($i / 2) + int($j / 3)) % 2) == 0 },
      5 => sub ($i, $j) { ((($i * $j) % 2) + (($i * $j) % 3)) == 0 },
      6 => sub ($i, $j) { (((($i * $j) % 2) + (($i * $j) % 3)) % 2) == 0 },
      7 => sub ($i, $j) { (((($i + $j) % 2) + (($i * $j) % 3)) % 2) == 0 },
   };
   my $matrix = $data->{matrix};
   my @masked;
   my $eside_size = $data->{eside_size};
   my $mask = $mask_for->{$mask_id};
   for my $i (0 .. ($eside_size - 1)) {
      for my $j (0 .. ($eside_size - 1)) {
         if (($matrix->[$i][$j] >= 0x36) && $mask->($i - 4, $j - 4)) {