digraphs.plp

   1 <(common.inc.plp)><:
   2
   3 my $mode = $Request || 'vim';
   4 my $include = 'digraphs' . ($mode ne 'vim' && "-$mode");
   5 my $cmp = exists $get{cmp} ? ($get{cmp} // 1) : !!$Request;
   6
   7 my $di = eval { Data($include) } || {};
   8 warn "error in $include: ", @{$@} if ref $@;
   9
  10 Html({
  11         title => "$mode digraph cheat sheet",
  12         version => '1.5',
  13         description => $di->{description} // [
  14                 "Complete table of digraph characters from",
  15                 ($di->{title} // $mode) . ".",
  16         ],
  17         keywords => [@{ $di->{keywords} // [] }, qw'
  18                 digraph mnemonic compose composition pair
  19                 character char glyph table unicode vim
  20         '],
  21         data => ["data/$include.json"],
  22 });
  23
  24 %{$di} or Abort(
  25         "Requested digraphs <q>$mode</q> not available",
  26         '404 request not found',
  27 );
  28
  29 say "<h1>$di->{title} Digraphs</h1>";
  30 say "<p>$_</p>" for $di->{intro} // ();
  31
  32 if (exists $get{v}) {
  33         # show characters for inverted mnemonics (vim alternatives)
  34         $di->{key}->{ substr($_, 1, 1) . substr($_, 0, 1) } ||= [
  35                 $di->{key}->{$_}->[0], '', 'l0 ex', '', $di->{key}->{$_}->[4]
  36         ] for grep { ref $di->{key}->{$_} } keys %{ $di->{key} };
  37 }
  38
  39 my @chars = (
  40         [qw{! " % ' ( ) * + , - . /}],
  41         ['0'..'9'], [qw{: ; < = > ?}],
  42         ['A'..'M'], ['N'..'Z'],
  43         ['a'..'m'], ['n'..'z'],
  44 );
  45 my @chars2 = (['_'], @chars);  # trailing character (extended set)
  46 my @columns = !exists $get{split} ? \@chars2 :
  47         ([@chars2[0, 1, 3, 4, 6]], [@chars2[2, 5, 7]]);
  48
  49 if ($mode eq 'xorg') {
  50         #TODO determine character usage from declared keys
  51         $chars2[0] = [qw( # ^ _ ` ~ )];
  52         @chars = @chars2;
  53 }
  54
  55 for my $colchars (@columns) {
  56 print '<table class="glyphs dimap"><col>';
  57 print qq'<colgroup span="$_">' for map {scalar @$_} @{$colchars};
  58 say '</colgroup><col>';
  59 for my $section (qw{thead tfoot}) {
  60         print "<$section><tr><th>↳";
  61         print '<th>', EscapeHTML($_) for map {@$_} @{$colchars};
  62         say '<th>&nbsp;';
  63 }
  64 for my $c1group (@chars) {
  65         print '<tbody>';
  66         for my $c1 (@$c1group) {
  67                 print '<tr><th>', EscapeHTML($c1);
  68                 for my $c2 (map {@$_} @$colchars) {
  69                         my $mnem = $c1 . $c2;
  70                         if (not defined $di->{key}->{$mnem}) {
  71                                 print '<td>';
  72                                 next;
  73                         }
  74                         if (ref $di->{key}->{$mnem} ne 'ARRAY') {
  75                                 printf '<td class="X Xr" title="%s">', EscapeHTML($mnem);
  76                                 next;
  77                         }
  78                         my ($codepoint, $name, $support, $script, $string) =
  79                                 @{ $di->{key}->{$mnem} };
  80
  81                         my $glyph = $string || !!$codepoint && chr $codepoint;
  82                         utf8::upgrade($glyph);  # prevent latin1 output
  83                         my $desc = $mnem . ($name && " ($name)");
  84                         my @class = ('X', grep {$_} $script);
  85                         push @class, $cmp ? $support :
  86                                 $di->{flagclass}->{$support} // "u-$support" if $support;
  87
  88                         $glyph = EscapeHTML($glyph);
  89                         $glyph = "<span>$glyph</span>" if $script =~ /\bZs\b/;
  90
  91                         printf "\n".'<td class="%s" title="%s">%s',
  92                                 join(' ', @class), EscapeHTML($desc), $glyph;
  93                 }
  94                 say "\n<th>", EscapeHTML($c1);
  95         }
  96 }
  97 say '</table>';
  98 print '<hr>' if exists $get{split};
  99 }
 100
 101 :>
 102 <div class="legend"><: unless ($cmp) { :>
 103         <table class="glyphs"><tr>
 104         <td class="X Cc">control
 105         <td class="X Zs"><span>space</span>
 106         <td class="X Mn">combining
 107         <td class="X Sk">spacing&nbsp;modifier
 108         <td class="X Pf">quote
 109         <td class="X Po">punctuation
 110         <td class="X So">symbol
 111         <td class="X Sm">math
 112         <td class="X Sc">currency
 113         <td class="X No">numeric
 114         <td class="X Greek">greek
 115         <td class="X Cyrillic">cyrillic
 116         <td class="X Latin">latin
 117         <td class="X Hebrew">hebrew
 118         <td class="X Arabic">arabic
 119         <td class="X Hangul">korean
 120         <td class="X Hiragana">japanese
 121         <td class="X Bopomofo">chinese
 122         </table>
 123 <: } :>
 124         <table class="glyphs"><tr><:
 125         printf qq(\n\t<td class="X %s">%s), $cmp ? $_ : $di->{flagclass}{$_} // "u-$_", $di->{flag}->{$_}
 126                 for sort keys %{ $di->{flag} };
 127 :>
 128         </table>
 129 </div>
 130