generate files to test / demonstrate .jsf colors

jsfgenerate.pl

#!/usr/bin/perl -w
# generate files to test .jsf colors.
# (c) 2019 utoddl@gmail.com
# GPL
use strict;

syntax() if @ARGV;
sub syntax {
  print qq[Usage: $0

  $0 generates files to test .jsf colors for 8, 16, or
  256 color terminals. The test files include three text files and
  corresponding .jsf files:

     sample_text.colordemo8        colordemo8.jsf
     sample_text.colordemo16       colordemo16.jsf
     sample_text.colordemo256      colordemo256.jsf

  You will have to copy the .jsf files to a valid 'syntax' directory:

     cp colordemo*.jsf ~/.ne/syntax/

  or link to them from one:

     for f in colordemo*.jsf ; do ln -s `pwd`/\$f ~/.ne/syntax/\$f ; done

  before starting "ne sample_text.colordemo*" or ne will not see the
  generated .jsf syntax definition files.
];
  exit;
}

my @attributes  = ('', qw( bold inverse blink dim underline));
my @foregrounds = ('', qw( white cyan magenta blue yellow green red black));
my @backgrounds = ('', qw( bg_white bg_cyan bg_magenta bg_blue bg_yellow bg_green bg_red bg_black));
my @FOREGROUNDS = ('', qw( WHITE CYAN MAGENTA BLUE YELLOW GREEN RED BLACK));
my @BACKGROUNDS = ('', qw( bg_WHITE bg_CYAN bg_MAGENTA bg_BLUE bg_YELLOW bg_GREEN bg_RED bg_BLACK));

# Limit the RGB values b/c when we do (0..5) we get
# a 92MB .jsf and a 25BM sample text file. That's just silly.
# By using only (0,2,5) the .jsf is 1.6MB with
# a 415KB sample text file.

my @RGBvals = (0,2,5);
my @fg_RGB = ('' , map { "fg_$_" } map { my $y = $_;
                                         map { $y . $_ } @RGBvals;
                                       } map { my $x = $_;
                                               map { $x . $_ } @RGBvals
                                             } @RGBvals);
my @bg_RGB = map { (my $x = $_) =~ s/fg_/bg_/; $x } @fg_RGB;

generate("colordemo8.jsf",
         "sample_text.colordemo8",
         \@foregrounds,
         \@backgrounds);

generate("colordemo16.jsf",
         "sample_text.colordemo16",
         [sort { lc $a cmp lc $b } (@foregrounds, @FOREGROUNDS)],
         [sort { lc $a cmp lc $b } (@backgrounds, @BACKGROUNDS)]);

generate("colordemo256.jsf",
         "sample_text.colordemo256",
         \@fg_RGB,
         \@bg_RGB);


sub generate {
  my ($jsffilename, $textfilename, $fgref, $bgref) = @_;
  (my $header = <<"  EOH") =~ s/^\s*//gm;
     # $jsffilename - JSF Syntax definition for testing color definitions.
     # The JSF Syntax system was designed and implemented by Joe Alen
     # for "joe" (Joe's Own Editor) and released under the GPL.
     # Adapted for "ne - The Nice Editor" by Daniele Filaretti under
     # the supervision of Professor Sebastiano Vigna.
     #   ne home page: http://ne.di.unimi.it/
     #   GitHub repo: https://github.com/vigna/ne/
     #   Discuss ne at http://groups.google.com/group/niceeditor/

     =idle
     =A
  EOH

  my %colorsdone = ();
  my @colordefs = ();
  my @state_blobs = ();

  (my $idle = <<"  EOR") =~ s/^    //gm;
    :idle idle
      *            eol
      "a-zA-Z0-9_" A buffer

    :eol idle
      *            eol
      "\\n"        idle

  EOR

  (my $sample_text = <<"  EOST") =~ s/^    //gm;

    This generated file demonstrates some of the possible color
    definitions available in .jsf syntax recognisers. Color definitions
    start with a (possibly empty) list of attributes followed by an
    optional foreground color and an optional background color.

    Although .jsf supports multiple attributes (bold, inverse, blink,
    dim, and underline), and also allows specifying the attributes,
    optional foreground and background colors in any order, the
    generated .jsf files are greatly restricted thus:

      * At most 1 attribute is accepted.
      * The optional attribute must come first on a line with no leading space.
      * The optional foreground and background colors must follow in that order.

    Otherwise the .jsf file grows too long to be practical. Similarly,
    the generated fg_### and bg_### values for the 256-color demo only
    use the values 0, 2, and 5. Using 0 through 5 would create
    prohibitively large files.

  EOST

  my %colortree = ();
  for my $attribute ( @attributes ) {
    for my $foreground ( @$fgref ) {
      for my $background ( @$bgref ) {
        my @terms = grep { $_ } $attribute, $foreground, $background;
        next unless @terms;
        my $colorname = join('_', 'A', @terms);
        my $colorspec = join(' ', @terms);
        if (! $colorsdone{$colorname}++) {
          push @colordefs, "=${colorname} ${colorspec}";
          $sample_text .= "${colorspec}:" . (' ' x (31-length($colorspec))) . 'The Quick Brown Font e=mc^2 13579 ~`;:@#$%^&*()-=_+<>./?!' . "\n";
          if (@terms == 3) {
            $colortree{$terms[0]}{$terms[1]}{$terms[2]}{'X'}++;
          } elsif (@terms == 2) {
            $colortree{$terms[0]}{$terms[1]}{'X'}++;
          } elsif (@terms == 1) {
            $colortree{$terms[0]}{'X'}++;
          }
        }
      }
    }
  }
  # traverse the %colortree, outputting blobs for each terminal node ('X')
  # and intermediate blobs for others.
  push @state_blobs, traverse('A', \%colortree);

  open(CT,'>',$jsffilename) or die;
  open(SA,'>',$textfilename) or die;
  print CT $header;
  print CT join("\n", @colordefs),"\n\n";
  print CT $idle;
  print CT @state_blobs;
  close CT;
  print SA $sample_text;
  close SA;
}

sub traverse {
  my ($prefix, $cref) = @_;
  my @blobs;
  my @strings;
  for my $color ( sort { lc $a cmp lc $b } keys %$cref ) {
    if ( $color ne 'X') {
      push @strings, $color;
      push @blobs, traverse("${prefix}_${color}", $cref->{$color});
    }
  }
  if (@strings) {
    push @blobs, string_blob($prefix, \@strings);
  } else {
    push @blobs, terminal_blob($prefix);
  }
  return @blobs;
}

sub string_blob {
  my ($stem, $strref) = @_;
  my $termstr = << "    EOTS";
    #================ ${stem} ==================
    :${stem}_final ${stem}
      *             ${stem}_final
      "\\n"         idle

    :to_${stem}_final idle
      *             ${stem}_final noeat
      ": "          to_${stem}_final

    :in_${stem} idle
      *             to_${stem}_final noeat
      " "           in_${stem}
      "a-zA-Z0-9_"  ${stem} noeat buffer

    :to_${stem} idle
      *             in_${stem} noeat

    :${stem} idle
      *  to_${stem}_final noeat strings
    EOTS
  for my $string ( @$strref ) {
    $termstr .= qq[      "$string" to_${stem}_${string}\n];
  }
  $termstr .= << "    DONE";
    done
      "a-zA-Z0-9_"  ${stem}

    DONE
  $termstr =~ s/^    //gm;
  return $termstr;
}

sub terminal_blob {
  my ($stem) = @_;
  (my $termstr = << "    EOBLOB")  =~ s/^    //gm;;
    #---------------- ${stem} ------------------
    :to_${stem} idle
      *    ${stem}_final noeat
      ": " to_${stem}

    :${stem}_final ${stem}
      *    ${stem}_final
      "\\n" idle

    EOBLOB
  return $termstr;
}