chiark - git - mdw - xyla/blob - t/dump-to-assgn

   1 #! /usr/bin/perl -w
   2 ###
   3 ### Convert dumps to `read_tree' input format
   4 ###
   5 ### (c) 2024 Straylight/Edgeware
   6 ###
   7
   8 ###----- Licensing notice ---------------------------------------------------
   9 ###
  10 ### This file is part of Xyla, a library of binary trees.
  11 ###
  12 ### Xyla is free software: you can redistribute it and/or modify it under
  13 ### the terms of the GNU Lesser General Public License as published by the
  14 ### Free Software Foundation; either version 3 of the License, or (at your
  15 ### option) any later version.
  16 ###
  17 ### Xyla is distributed in the hope that it will be useful, but WITHOUT
  18 ### ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  19 ### FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
  20 ### License for more details.
  21 ###
  22 ### You should have received a copy of the GNU Lesser General Public
  23 ### License along with Xyla.  If not, see <https://www.gnu.org/licenses/>.
  24
  25 use autodie;
  26 use strict;
  27
  28 use Getopt::Std;
  29
  30 our $opt_r;
  31 getopts "r";
  32
  33 sub node ($) {
  34   my ($k) = @_;
  35   return { key => $k, left => undef, right => undef, flags => "" };
  36 }
  37
  38 sub read_tree ($);
  39 sub read_tree ($) {
  40   my ($s) = @_;
  41   if ($s =~ /^ \s* _ \s* (.*) $/x) { return undef, $1; }
  42   $s =~ /^ \s* \( \s* (.*) $/x or die "bad string";
  43   (my $left, $s) = read_tree $1;
  44   $s =~ /^ \s* ([*]*) \s* (\d+) \s* (.*) $/x or die "bad string";
  45   (my $flags, my $key) = ($1, $2);
  46   (my $right, $s) = read_tree $3;
  47   $s =~ /^ \s* \) \s* (.*) $/x or die "bad string";
  48   my $node = node $key;
  49   $node->{left} = $left; $node->{right} = $right; $node->{flags} = $flags;
  50   return $node, $1;
  51 }
  52
  53 my @N = ();
  54 my @LV = ();
  55 my $SP = 0;
  56
  57 my $firstp = 1;
  58 my $tree = undef;
  59 LINE: while (<>) {
  60   chomp;
  61
  62   if ($firstp && /^\s*[(_]/) {
  63     ($tree, my $tail) = read_tree $_;
  64     $tail =~ /^ \s* $/x or die "bad string";
  65     last LINE;
  66   }
  67
  68   $firstp = 0;
  69   m{^ \s+ \#0x[0-9a-f]{8} \s+  \(n \s* = \s* \d+\)
  70       (\s+) \(([ *+=-])\) (?: \s+ (0x[0-9a-f]{8} \s* \$)) \s+ (\d+) $}x
  71     or die "bad line `$_'";
  72   my $lv = length $1;
  73   my $sigil = $2;
  74   my $weight = $3;
  75   my $key = $4;
  76
  77   my $node = node $key;
  78   if ($opt_r && $sigil eq "*") { $node->{flags} .= "*"; }
  79   if (defined $weight) { $node->{flags} .= $weight . " "; }
  80   my $left = undef;
  81   while ($SP && $LV[$SP - 1] > $lv)
  82     { $SP--; my $n = $N[$SP]; $n->{right} = $left; $left = $n; }
  83   $node->{left} = $left; $N[$SP] = $node; $LV[$SP] = $lv; $SP++;
  84 }
  85 while ($SP) { $SP--; my $n = $N[$SP]; $n->{right} = $tree; $tree = $n; }
  86
  87 sub show_tree ($$$$);
  88 sub show_tree ($$$$) {
  89   my ($node, $dp, $lp, $nl) = @_;
  90   if ($node->{flags} eq "*") { $dp = ($dp&-2) + 1; }
  91   if ($node->{left}) {
  92     show_tree $node->{left}, $dp + 1, $lp + 1, $nl;
  93     print "\n" . "\t" x $dp . $node->{flags} . $node->{key};
  94   } else {
  95     print "\n" if $nl;
  96     print "\t" x $dp . "(" x $lp . "_ " . $node->{flags} . $node->{key};
  97   }
  98   if ($node->{right}) { show_tree $node->{right}, $dp + 1, 1, 1; }
  99   else { print " _"; }
 100   print ")";
 101 }
 102 show_tree $tree, 1, 1, 0;
 103 print "\n";
 104
 105 ###----- That's all, folks --------------------------------------------------