commitid.scad.pl

   1 #!/usr/bin/perl -w
   2 use strict;
   3
   4 $SIG{__WARN__} = sub { die @_; };
   5
   6 #  xxx much of the comment below is TODO
   7 #
   8 # Usage:
   9 #
  10 #   .../commitid.scad.pl [OPTION...] [STRING...] >commitid.scad.new \
  11 #     && mv -f commitid.scad.new commitid.scad
  12 #
  13 # Options:
  14 #
  15 #   --git    generate git commit indications, as shown below
  16 #            (this is the default if no strings are requested with -t)
  17 #
  18 #   --git=objid
  19 #            generate git commit indication based on commit object only
  20 #            (ie avoid counting commits)
  21 #
  22 #   -i       do not generate `+' if git-untracked files are present
  23 #
  24 #   [-t[FORM]] TEXT
  25 #            generate a form FORM containing TEXT
  26 #            TEXT can contain newlines (final newline usually undesirable)
  27 #            if FORM not specified, generates Arg0 Arg1 Arg2 in sequence
  28 #            character set is SPC 0-9 a-f + *
  29 #
  30 # We generate a physical indication of which commit was used.
  31 #
  32 # We provide for scaling factors with dynamic variables:
  33 #    $Commitid_pixelsz        if not set, we use 0.8 } multiplied
  34 #    $Commitid_scale          if not set, we use 1.0 }  together
  35 #    $Commitid_depth          if not set, we use xy pixel size from above / 2
  36 #    $Commitid_depth_scale    if not set, we use 1.0 (multiplies depth above)
  37 #    $Commitid_max_best_scale if not set, we use 2.0 (max mult of xy in Best)
  38 #
  39 # We have auto-sizing modules:
  40 #
  41 #   module Commitid_BestCount_2D(max_sz, margin=Commitid_pixelsz()) { ... }
  42 #   module Commitid_BestCount   (max_sz, margin=Commitid_pixelsz()) { ... }
  43 #   module Commitid_BestObjid_2D(max_sz, margin=Commitid_pixelsz()) { ... }
  44 #   module Commitid_BestObjid   (max_sz, margin=Commitid_pixelsz()) { ... }
  45 #      // max_sz should be [x,y]
  46 #
  47 # For each form we have
  48 #
  49 #    module Commitid_Form_2D() { ... }
  50 #    module Commitid_Form() { ... }
  51 #    function Commitid_Form_sz()     => [ x, y ]
  52 #
  53 #  These have their origin in the bottom left corner.  The 3D model
  54 #  is a positive, has its origin halfway through, and is twice the
  55 #  depth in height, so it can be added or subtracted.
  56 #
  57 # And we provide
  58 #
  59 #   function Commitid_pixelsz()    // $Commitid_pixelsz * $Commitid_scale
  60 #   function Commitid_depth()      // see above
  61 #
  62 # We can generate these forms:
  63 #
  64 #  In each case:
  65 #    if tree is dirty, * is suffixed or prefixed to count or commitid
  66 #    if tree has untracked files, + is added
  67 #    (where it is added depends on the Form; in any case it does not
  68 #    change the size, but steals space from digits)
  69 #
  70 #   Small2 Small3 ... Small10:
  71 #       git rev-list --first-parent --count HEAD
  72 #       typically 3-4 characters but we allow for up to 6
  73 #       padded with zeroes; if too long we reduce mod 10^n
  74 #       eg if the count is 123456
  75 #            Small5    3456*
  76 #            Small8    _*123456    (where _ are spaces)
  77 #       the git objectid is included if it will fit
  78 #       unambiguously and usefully eg
  79 #            Small9    ab*123456
  80 #
  81 #   Small2S Small4S ... Small10S:
  82 #   Small3T Small9T:
  83 #       same but split into two lines (S) or three lines (T) eg
  84 #            Small4S  45     Small6T   _3
  85 #                     6*               45
  86 #                                      6*
  87 #
  88 #   Git2 Git3 ... Git10:
  89 #   Git4S Git6S ... Git10S:
  90 #   Git6T Git9T:
  91 #       git-rev-parse HEAD   (prefix of requested length)
  92 #       eg if the commitid is abcdef0123...
  93 #            Git5    abcd*
  94
  95 #   Full4 Full6 ... Full20:
  96 #       git-rev-list --first-parent --count HEAD
  97 #       git-rev-parse HEAD
  98 #       (all on two lines)
  99 #       eg
 100 #            Full6    abcdef       Full8     abcdef01
 101 #                     23456*                 _123456*
 102 #
 103 #   Full6T Full9T ... Full30T
 104 #       as Full but commit is split over two lines
 105 #       for a 3-line message; eg
 106 #             Full9T    abc
 107 #                       de*
 108 #                       456
 109 #
 110 #   FontDemo
 111 #
 112 #   Arg0, Arg1, ...
 113 #       Strings passed on command line
 114
 115 sub p { print @_ or die $!; }
 116
 117 p <<'END';
 118 // *** AUTOGENERATED - DO NOT EDIT *** //
 119 function Commitid_pixelsz() =
 120   ($Commitid_pixelsz       ? $Commitid_pixelsz       : 0.8) *
 121   ($Commitid_scale         ? $Commitid_scale         : 1.0);
 122 function Commitid_depth() =
 123   ($Commitid_depth         ? $Commitid_depth         : Commitid_pixelsz()/2) *
 124   ($Commitid_depth_scale   ? $Commitid_depth_scale   : 1.0);
 125 function Commitid__scale() =
 126   Commitid_pixelsz() / 0.2;
 127 END
 128
 129 sub chrmodname ($) {
 130     my ($chr) = @_;
 131     my $chrx = sprintf '%#x', ord $chr;
 132     return "Commitid__chr_$chrx";
 133 }
 134
 135 our $gtm_demo_i = -1;
 136 our $gtm_demo_j;
 137 our @gtm_demo_o;
 138
 139 sub gentextmodule_demo_start_batch () {
 140     $gtm_demo_j = 0;
 141     $gtm_demo_i++;
 142 }
 143
 144 sub gen3dmodule ($@) {
 145     my ($modb,@argl) = (@_);
 146     p "module ${modb}(".(join ', ', @argl)."){\n";
 147     p " d=Commitid_depth();\n";
 148     p " translate([0,0,-d]) linear_extrude(height=d*2)\n";
 149     p "  ${modb}_2D(".(join ',', map { m/=/ ? $` : $_ } @argl).");\n";
 150     p "}\n";
 151 }
 152
 153 sub gentextmodule ($@) {
 154     my ($form, @lines) = @_;
 155     my $modb = "Commitid_$form";
 156     p "module ${modb}_2D(){\n";
 157     p " // |$_|\n" foreach @lines;
 158     p " scale(Commitid__scale()){\n";
 159     my $y = @lines;
 160     my $cols = 1;
 161     foreach my $line (@lines) {
 162         $y--;
 163         my $x = 0;
 164         foreach my $chr (split //, $line) {
 165             p sprintf "  translate([%d * 0.8, %d * 1.2]) %s();\n",
 166                 $x, $y, chrmodname $chr
 167                 if $chr =~ m/\S/;
 168             $x++;
 169         }
 170         $cols = $x if $x > $cols;
 171     }
 172     p " }\n";
 173     p "}\n";
 174     gen3dmodule($modb);
 175
 176     p sprintf "function %s_sz() = Commitid__scale() * 0.1 * [ %d, %d ];\n",
 177         $modb, 2 * ($cols * 4 - 1), 2 * (@lines * 6 - 1);
 178
 179     push @gtm_demo_o, <<END;
 180  translate([$gtm_demo_i * st[0], $gtm_demo_j * st[1]]) {
 181   difference(){
 182    color("blue") translate([-e,-e]) square(${modb}_sz() + 2*[e,e]);
 183    square(${modb}_sz());
 184   }
 185   ${modb}_2D();
 186 }
 187 END
 188     $gtm_demo_j++;
 189 }
 190
 191 our @demo;
 192
 193 sub parsefont () {
 194     my %cellmap;
 195     for (;;) {
 196         $_ = <DATA> // die;
 197         last if %cellmap && !m/\S/;
 198         next unless m/\S/;
 199         chomp;
 200         s{^(.) }{};
 201         $cellmap{$1} = $_;
 202     }
 203     my %chrpolys;
 204     while (<DATA>) {
 205         next unless m/\S/;
 206         chomp;
 207         my @chrs = split / /, $_;
 208         <DATA> !~ m/\S/ or die;
 209         foreach my $row (reverse 0..4) {
 210             $_ = <DATA>;
 211             chomp;
 212             s{^}{ };
 213             $_ .= ' ' x 8;
 214             m{\S/\S} and die;
 215             s{/(?=\s)}{L}g;
 216             s{/(?=\S)}{r}g;
 217             s{\\(?=\s)}{l}g;
 218             s{\\(?=\S)}{R}g;
 219             p "// $_\n";
 220             foreach my $chr (@chrs) {
 221                 s{^ }{} or die "$chr $_ ?";
 222                 foreach my $col (0..2) {
 223                     my @verts;
 224                     if (s{^ }{}) {
 225                     } elsif (s{^\S}{}) {
 226                         my $f = $cellmap{$&};
 227                         die unless $f;
 228                         $f =~ s/\b\d/ sprintf '%05d', $col*2000 + $&*1025 /ge;
 229                         $f =~ s/\d\b/ sprintf '%05d', $row*2000 + $&*1025 /ge;
 230                         push @{ $chrpolys{$chr} }, [ split / /, $f ];
 231                     } else {
 232                         die "$_ ?";
 233                     }
 234                 }
 235             }
 236             die "$_ ?" if m{\S};
 237         }
 238     }
 239
 240     my $demo = '';
 241     my $democols = 6;
 242     foreach my $chr (sort keys %chrpolys) {
 243         my $mod = chrmodname $chr;
 244         p "module $mod () {\n";
 245         foreach my $poly (@{ $chrpolys{$chr} }) {
 246             p " polygon([";
 247             my $delim = "";
 248             foreach my $pt (@$poly) {
 249                 p $delim;
 250                 $pt =~ s{\d{5}}{$&,};
 251                 $pt =~ s{\b\d}{$&.}g;
 252                 p "[$pt]";
 253                 $delim = ',';
 254             }
 255             p "]);\n";
 256         }
 257         p "}\n";
 258         $demo .= $chr;
 259     }
 260     @demo = reverse $demo =~ m{.{1,$democols}}go;
 261 }
 262
 263 parsefont();
 264
 265 our $do_git; # contains may chars 'c' (count) and/or 'o' (object)
 266 our $do_git_untracked = 1;
 267 our $argcounter;
 268
 269 our @forms;
 270
 271 sub rjustt ($$;$) { # right justify and truncate (ie, pad and truncate at left)
 272                     # always includes prefix
 273     my ($sz, $whole, $prefix) = @_;
 274     $prefix //= '';
 275     my $lw = length $whole;
 276     my $spare = $sz - $lw - (length $prefix);
 277     return
 278         ($spare > 0 ? (' ' x $spare) : '').
 279         $prefix.
 280         substr($whole, ($spare < 0 ? -$spare : 0));
 281 }
 282
 283 sub ljustt ($$;$) {
 284     my ($sz, $whole, $suffix) = @_;
 285     $suffix //= '';
 286     $sz -= length $suffix;
 287     return sprintf "%-${sz}.${sz}s%s", $whole, $suffix;
 288 }
 289
 290 sub genform ($@) {
 291     my ($form, @lines) = @_;
 292     gentextmodule($form, @lines);
 293     my $f = {
 294         Form => $form,
 295         Chars => (length join '', @lines),
 296         Lines => (scalar @lines),
 297         Ambiguous => ($form =~ m/Full/ && !grep { m/\W/ } @lines),
 298     };
 299     push @forms, $f;
 300 }
 301
 302 sub genform_q ($$$) {
 303     my ($form, $s, $lines) = @_;
 304     $gtm_demo_j++;
 305     my $l = length $s;
 306     return if $l % $lines;
 307     my $e = $l/$lines;
 308     return if $e < 2;
 309     $gtm_demo_j--;
 310     genform($form, $s =~ m/.{$e}/g);
 311 }
 312
 313 sub genform_plusq ($$) {
 314     my ($form, $s) = @_;
 315     genform($form, $s);
 316     genform_q("${form}S", $s, 2);
 317     genform_q("${form}T", $s, 3);
 318 }
 319
 320 our @gcmd;
 321
 322 sub gitrun_start () {
 323     open F, "-|", @gcmd or die "$gcmd[0]: start: $!";
 324 }
 325
 326 sub gitrun_done (;$) {
 327     my ($errok) = @_;
 328     $?=0; $!=0;
 329     return if close F;
 330     return if $errok;
 331     die $! if $!;
 332     die "@gcmd failed ($?)\n";
 333 }
 334
 335 sub gitoutput (@) {
 336     (@gcmd) = (qw(git), @_);
 337     gitrun_start;
 338     $_ = <F>;
 339     gitrun_done;
 340     defined or die "@gcmd produced no output";
 341     chomp or die "@gcmd produced no final newline";
 342     $_;
 343 }
 344
 345 sub do_git () {
 346     return unless $do_git;
 347
 348     @gcmd = qw(git status --porcelain);
 349     push @gcmd, qw(--untracked=no) unless $do_git_untracked;
 350
 351     my $git_dirty = '';
 352     gitrun_start;
 353     while (<F>) {
 354         if (m/^\?\?/ && $do_git_untracked) {
 355             $git_dirty = '+';
 356             next;
 357         }
 358         $git_dirty = '*';
 359         last;
 360     }
 361     gitrun_done($git_dirty eq '*');
 362
 363     my $git_count;
 364     my $git_object;
 365
 366     if ($do_git =~ m/c/) {
 367         $git_count = gitoutput qw(rev-list --first-parent --count HEAD);
 368     }
 369     if ($do_git =~ m/o/) {
 370         $git_object = gitoutput qw(rev-parse HEAD);
 371     }
 372
 373     foreach my $sz (2..10) {
 374         gentextmodule_demo_start_batch();
 375
 376         if (defined($git_count)) {
 377             my $smallstr = rjustt($sz, $git_count, $git_dirty);
 378             if (defined($git_object) && $sz >= length($git_count) + 3) {
 379                 $smallstr = $git_object;
 380                 $smallstr .= ($git_dirty || ' ');
 381                 $smallstr .= $git_count;
 382                 $smallstr = rjustt($sz, $smallstr);
 383             }
 384             genform_plusq("Small$sz", $smallstr);
 385         }
 386
 387         genform_plusq("Git$sz", ljustt($sz, $git_object, $git_dirty))
 388             if defined $git_object;
 389
 390         if (defined $git_count && defined $git_object) {
 391             genform("Full".($sz*2),
 392                     ljustt($sz, $git_object),
 393                     rjustt($sz, $git_count, $git_dirty));
 394
 395             my $e = $sz;
 396             genform("Full".($e*3)."T",
 397                     ljustt($e*2, $git_object, $git_dirty)
 398                     =~ m/.{$e}/g,
 399                     rjustt($e, $git_count));
 400         }
 401     }
 402 }
 403
 404 sub do_some_best ($$) {
 405     my ($modname, $formre) = @_;
 406     my $fullmodname = "Commitid_${modname}_2D";
 407     my @argl = qw(max_sz margin=Commitid_pixelsz());
 408     p "module $fullmodname(".(join ', ', @argl).") {\n";
 409     my $mbs = '$Commitid_max_best_scale';
 410     p " sc_max = $mbs ? $mbs : 2;\n";
 411     p " sz = max_sz - 2*[margin,margin];\n";
 412     my @do;
 413     foreach my $f (
 414         sort {
 415             $b->{Chars} <=> $a->{Chars} or
 416             $a->{Lines} <=> $b->{Chars}
 417         }
 418         grep {
 419             $_->{Form} =~ m/$formre/ &&
 420             !$_->{Ambiguous}
 421         }
 422         @forms
 423     ) {
 424         my $form = $f->{Form};
 425         p " sz_$form = Commitid_${form}_sz();\n";
 426         foreach my $rot (qw(0 1)) {
 427             my $id = "${form}_r${rot}";
 428             p " sc_$id = min(sc_max";
 429             foreach my $xy (qw(0 1)) {
 430                 p ",sz[$xy]/sz_$form","[",(($xy xor $rot)+0),"]";
 431             }
 432             p ");\n";
 433             push @do, " if (sc_$id >= 1.0";
 434             push @do, " && sc_$id >= sc_${form}_r1" if !$rot;
 435             push @do, ") {\n";
 436             push @do, "  translate([margin,margin]) scale(sc_$id)\n";
 437             push @do, "   rotate(90) translate([0,-sz_$form"."[1]])\n" if $rot;
 438             push @do, "   Commitid_${form}_2D();\n";
 439             push @do, " } else";
 440         }
 441     }
 442     push @do, <<END;
 443  {
 444   echo("$fullmodname could not fit anything in", max_sz);
 445  }
 446 END
 447     p $_ foreach @do;
 448     p "}\n";
 449
 450     gen3dmodule "Commitid_$modname", @argl;
 451 }
 452
 453 sub do_git_best () {
 454     return unless $do_git;
 455
 456     # Auto-computer for `best fit'
 457     #
 458     # We have two best fit approaches: with count, and git-object-id-only
 459     #
 460     # For `with count', we only ever include the git object id if the
 461     # result would be unambigous.  That means that at least one space
 462     # or punctuation was generated.
 463     #
 464     # We sort the options by firstly number of characters
 465     # (decreasing), and then by number of lines (increasing) and
 466     # try each one both ways round.
 467
 468     do_some_best('BestCount', 'Small|Full') if $do_git =~ m/c/;
 469     do_some_best('BestObjid', 'Git|Full') if $do_git =~ m/o/;
 470 }
 471
 472 while (@ARGV) {
 473     $_ = shift;
 474     if (m/^--(no)?-git$/) {
 475         $do_git = $1 ? '' : 'co';
 476     } elsif (m/^---git=objid$/i) {
 477         $do_git = 'o';
 478     } elsif (m/^-i$/) {
 479         $do_git_untracked = 0;
 480     } elsif (m/^-t(.*)$/) {
 481         my $form = $1;
 482         die "bad usage: -t needs string argument\n";
 483         $_ = shift;
 484         gentextmodule($form, split /\n/, $_);
 485         $argcounter //= 0;
 486     } elsif (m/^[^-]/) {
 487         gentextmodule("Arg$argcounter", $_);
 488         $argcounter++;
 489     } else {
 490         die "bad usage: unknown option \`$_'\n";
 491     }
 492 }
 493
 494 $do_git //= defined($argcounter) ? '' : 'co';
 495
 496 gentextmodule_demo_start_batch();
 497 gentextmodule('FontDemo', @demo);
 498
 499 do_git();
 500 do_git_best();
 501
 502 p "module Commitid_2DDemo(){\n";
 503 p " st = Commitid__scale() * [ 10, 5 ];\n";
 504 p " e  = Commitid_pixelsz();\n";
 505 p $_ foreach @gtm_demo_o;
 506 p "}\n";
 507
 508 flush STDOUT or die $!;
 509 close STDOUT or die $!;
 510
 511 __DATA__
 512
 513 # 00 20 22 02
 514 l 00 20 02
 515 r 00 20 22
 516 L 00 22 02
 517 R 20 22 02
 518 > 00 20 22 02 11
 519 < 00 20 11 22 02
 520
 521 0 1 2 3 4 5 6 7 8 9
 522
 523 /#\  r  /#\ ##\ # # ### //  ### /#\ /#\
 524 # # /#    #   # # # #   #     # # # # #
 525 # #  #  /#/ ##< \## ##\ ##\  // >#< \##
 526 # #  #  #     #   #   # # #  #  # #   #
 527 \#/ /#\ ### ##/   # ##/ \#/  #  \#/ ##/
 528
 529 a b c d e f
 530
 531     #         #     /##
 532     #   /##   # /#\ #
 533 /## ##\ #   /## #r# ###
 534 # # # # #   # # #/  #
 535 \## ##/ \## \## \#/ #
 536
 537 + *
 538
 539     # #
 540  #  \#/
 541 ### ###
 542  #  /#\
 543     # #