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

[Doug Miles]

Thanks.  I'll have a look at this...

Scott Walters wrote:
> 
> 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;