Phoenix.pm: Fwd:Code as per Doug's request: parsing nested structures (fwd)

[Scott Walters]

Sending this again... about a month or two late...
Changed my config so I wasn't running pine as root,
so my email changed, and apparently majordomo started
ignoring me (justifibly so). It should have been
ignoring me for mailing as root, too.

-scott

---------- Forwarded message ----------
Date: Sat, 5 May 2001 18:15:35 -0700 (PDT)
From: Scott Walters <phaedrus at illogics.org>
To: phoenix-pm-list at happyfunball.pm.org
Subject: Code as per Doug's request: parsing nested structures


Perl Mungers,

Last meeting, I whiped out a bit of code in response to a comment
by Doug, who asked me to post the code. (Doug had nested, balanced
strings qouting other strings.)
Please keep in mind that this code was never ment to be seen by
anyone else ;)
The output from it is visible at: http://weehours.net/map.cgi
The code in it's entirety is at the end... the relavent bit is:

# we reconstruct this array from data stored in a file:
@flags=();

# the indexes are initialized to 0, and the names of the indexes are
# stored in the @dice array. we use softreferences to increment the
# variables of the same names.
$depth=-1; $x=0; $y=0; $z=0;
@dice=qw(y x foo);
# the \G in a regex matches were you left off last time and works in
# conjunction with the /g flat on the end. we loop on this, taking off
# a single "bite" each time, which will be one of: ({ number })
# we ignore commas that may be on the end.
# depending on which of those three things we found, we work with a
# "higher" index, push a number onto the end of the array, or work with
# a "lower" index and increment that index and 0 the indexes below it.
# note that all numbers are pushed on to a hardcoded depth.. the push()
# call would have to be changed to allow a variable depth (construct an
# index from the $depth variable).
while($flags =~ m/\G(?:(\Q({\E)|([0-9]+)|(\Q})\E)),?/go) {
  if($1 eq '({') {
    $depth++;
  } elsif(length($2)) {
    push(@{$flags[$x]->[$y]}, $2);
  } elsif($3 eq '})') {
    $depth--;
    ${$dice[$depth]}++;
    # this limits the array to essentially 3D... this next line SHOULD be
    # something more like...:
    # for(my $i=$depth+1;$i<scalar @dice;$i++) { ${$dice[$i]}=0; }
    # as mentioned, this is kinda a kludge. anyway, this resets "lesser"
    # indexes after incrementing a "higher" index, like when you go from
    # Perl 5.000503 to Perl 5.6.0, the 3 turns into a 0, as an example.
    ${$dice[$depth+1]}=0;
    # print "x: $x  y: $y\n";
  }
}

Sample data: (Actually, the dataset is kinda largish and getting bigger):
(This was generated by another program, not a format I created):
flags ({({({0,0,0,0,365,382,65,0,0,}),({0,0,382,83,86,0,0,0,0,}),({0,0,0,0,382,35,3263,0,0,}),}),})

If this makes sence to anyone, and they want me to fix the caveats, I'll do
so, but not unless someone actually will benefit from me doing so ;)
The comments in the real program aren't very good either. Essentially,
this program is a test tool... I'm converting a graph-based "map" into
a 3d array, and wanted to see the output of that conversion to verify
correct operation of the conversion tool.

-scott



#!/usr/bin/perl

# we looks at the exit bits in a map.o file (from WeeHours map server daemon) and
# render an image that represents the exits

require 5.6.0;

open MAP, '/home/ah/map.o';

sub tilewidth () { 9 }
sub halfwidth () { int tilewidth/2 }

while(<MAP>) {
  my $line=$_;
  (my $key, my $value) = $line =~ m/([a-z_]+) (.*)/;
  $lines{$key} = $value;
}
close MAP;

$flags = $lines{'flags'};

@flags=();
$depth=-1; $x=0; $y=0; $z=0;
@dice=qw(y x foo);
while($flags =~ m/\G(?:(\Q({\E)|([0-9]+)|(\Q})\E)),?/go) {
  if($1 eq '({') {
    $depth++;
  } elsif(length($2)) {
    push(@{$flags[$x]->[$y]}, $2);
  } elsif($3 eq '})') {
    $depth--;
    ${$dice[$depth]}++;
    ${$dice[$depth+1]}=0;
    # print "x: $x  y: $y\n";
  }
}

# map exit flag bits to which pixels to set to illustrate that exit.
# [x, y] offset of pixel to toggle, measured from top left of image.
@exits = (
  [halfwidth,0, halfwidth+1,0,  halfwidth-1,0],             # bit 1 - north
  [0,halfwidth, 0,halfwidth+1,  0,halfwidth-1],             # bit 2 - west
  [-1,halfwidth, -1,halfwidth+1, -1,halfwidth-1],           # bit 3 - east
  [halfwidth,-1, halfwidth+1,-1, halfwidth-1,-1],           # bit 4 - south
  [halfwidth,halfwidth-1],      # bit 5 - up
  [halfwidth,halfwidth+1],      # bit 6 - down
  undef,                      # bit 7 - ignoring
  undef,                      # bit 8 - ignoring
  undef,                      # bit 9 - ignoring
  undef,                      # bit 10 - ignoring
  [0,1, 1,0, 1,1, 0,2, 2,0],                                # bit 11 - northwest
  [-1,1, -2,0, -2,1, -3,0, -1,2],                           # bit 12 - northeast
  [0,-2, 1,-1, 1,-2, 0,-3, 2,-1],                           # bit 13 - southwest
  [-1,-2, -2,-1, -2,-2, -1,-3, -3,-1],                      # bit 14 - southeast
);

# in our modifications to the standard tiles listed in @exits, this lets us abbreviate tilewidth-x as just -x.
foreach my $i (@exits) {
  if($i) {
    foreach my $j (@$i) {
      $j=tilewidth+$j if($j<0);
    }
  }
}

for($y=0;$y<scalar @flags;$y++) {
  for($x=0;$x<scalar @{$flags[$y]};$x++) {
    @glyph = (0b0011111110,
              0b0110000011,
              0b0100000001,
              0b0100000001,
              0b0100000001,
              0b0100000001,
              0b0100000001,
              0b0110000011,
              0b0011111110,
    );
    $flag = $flags[$y][$x][1];  # [1] is the Z value  -- this is the "main floor". shouldnt be hardcode, though.
    for($i=0;$i<scalar @exits;$i++) {
      if($flag & 1<<$i) {
        $exitsfound++;
        print STDERR "debug: at $x $y found exit bit position $i\n";
        for($j=0;$j<scalar @{$exits[$i]};$j+=2) {  
          # each set of points specified for this exit in @exits' entry for this flag...
          # *t = \$glyph[$exits[$i][$j+1]][$exits[$i][$j]]; $t=$t?0:1;
          *t = \$glyph[$exits[$i][$j+1]];   # reference to part of glyph indexed by 'y'
          $t = $t ^ ((1<<(tilewidth-1))>>$exits[$i][$j]);  # then with bit corresponding to 'x' flipped
        }
      }
    }
    $glyphs[$x][$y]=[@glyph];
    #if($exitsfound != $lastexitsfound) {
    #  print STDERR "debug: using glyph:\n", join('', @{$glyph[0]}, "\n", @{$glyph[1]}, "\n", @{$glyph[2]}, "\n");
    #  $lastexitsfound=$exitsfound;
    #}
  }
}
print STDERR $exitsfound, " exits found\n";

$ydim=scalar(@flags); $xdim=scalar(@{$flags[0]});
@flags=(); # reclaim memory...

open PPM, '>/tmp/map.ppm';
print PPM "P3\n#just another Perl script\n", $xdim*tilewidth, " ", $ydim*tilewidth, "\n255\n";
for($y=0;$y<scalar @{$glyphs[0]};$y++) {
  for($i=0;$i<tilewidth;$i++) {
    for($x=0;$x<scalar @glyphs;$x++) {
      $color = ($x == $xdim/2 && $y == $ydim/2) ? '254,10,10,' : '255,255,255,';
        
      # print PPM "# $x $y $i\n";
      print PPM (
        map { $glyphs[$x][$y][$i] & ((1<<(tilewidth-1))>>$_) ? $color : '0,0,0,' } (0 .. tilewidth-1),
      );
      print PPM "\n";
    }
  }
}
close PPM;

@glyphs=(); # reclaim memory...

print "Content-type: image/gif\n\n" if($ENV{'SERVER_NAME'});

open GIF, '/usr/local/bin/ppmtogif /tmp/map.ppm |';
# open GIF, '/usr/local/bin/pnmscale -xscale 4 -yscale 4 /tmp/map.ppm | /usr/local/bin/ppmtogif|';
while(read(GIF,$buf, 1024)) {
  print $buf;
}
close GIF;