display | more...
This is explained at Degrees of Everything and for now is kinda aimed at edev members.
For now, this code is also posted at http://charon.sjs.org/~mcc/epathfind.pl

Thank you for looking. I hope it's OK, i hope my code and comments are clear enough :) Enjoy (you won't)


[%
# EVERYTHING PATHFINDER .. VERSION 0.004
# i don't think this even works.
# any explanation of this can be found in the node linked at the bottom.. please read it
# the comments have been BASTARDISED so that i can post this on e2 using a PRE tag. I wish
# --- I had just posted it offsite.
# -- mcc@charon.sjs.org

# Versions of this
# * 0     : "\0" (01.20)
# * 0.001 : N-wing explains the ever-cryptic "$str" thing to me; i had been doing it wrong..
# * 0.002 : N-wing points out some problems (with qq[] and my list and such) and they get fixed..
# * 0.003 : Fixed a couple typos.
# * 0.004 : Found a typo (02.22)

# These two things have been abstracted up here so that the operator can easily redefine the concept
    # of a "link", or hijack the "random nodes", in their implementation..
sub dgetlinks  {return @{ selectLinks $_[0], "food" } }; #pass node_id, get list of linked node_ids
sub dgetrandom {return ${getNodeById(getRandomNode, 'light')}{title};}; #returns random node title

############################# Operational half. #############################
# in: $(env)dsname, $(env)dgname, @(env)davoid -- start node, goal node, avoid list.
# i'm assuming query->param automatically list-izes parameters passed to it seperated by commas.
# --- err-- it does, doesn't it...??
# out: 
my ($derror, $dtouch, $dcoll, $dacoll, @dpath); 

if ($query->param('dsname') and $query->param('dgname')) {
OPERATE: { #surely there are better ways to do exception handling in perl than this?
    # This script starts at both ends and works toward the center. This is why if you look everything
    # --- seems redundant, everything has to be done twice-- because it's trying to run itself from 
    # --- both directions at once. The reason for this is that if it started at one end and worked 
    # --- toward the other, and there turned out to be NO path between the two, this script could have
    # --- to touch every single node on the system before it realized what was going on.
    # As such we need dupes of all used variables. Items in "touch" have the touched node's id for the 
    # --- key, and contain the id of the node that linked that node. (the items with keys of dstart or
    # --- dend contain null.)

    my ( $dstart=nodeId($query->param('dsname') ), %d1touch, @d1passq, @d1nextpassq,
         $dend=nodeId($query->param('dgname') ),   %d2touch, @d2passq, @d2nextpassq,
         %davoid, $dwin );
    
    $derror .= (qq(<br>Starting node "), $query->param('dsname'), qq(" does not exist.)) 
        and last OPERATE unless ($dstart);
    $derror .= (qq(<br>Starting node "), $query->param('$dgname'), qq(" does not exist.))
        and last OPERATE unless ($dend); 

    foreach $nodename ($query->param('davoid')) {$davoid{nodeId($nodename)}=0} 
                                    # ^--- dump it all into a nice little hash
    @d1passq=$dstart; @d2passq=$dend; # set up start thing
    $d1touch{$dstart}=0; $d2touch{$dend}=0; #dstart and dend are the only keys equal to 0
    
    PASS: while(1) { 
        # ( Before i start, here's the pseudocode algorithm i wrote as the first version of this. I left
        # ---  it here because my code comments are mediocre :)
        #
        # PASS: for each item in passqueue, do the following twice, once for each end:
        #   load all of item's links into @checknow
        #   CHECK: for each link in checknow:
        #     if link exists in (env)davioid or my touchhash, increment (env)dcoll or (env)dacoll
        # --- 	and next CHECK.
        #     put item into touchhash with key link. (increment dtouch?)
        #     if link exists in other touchhash, store link in dwin and last PASS
        #     add link to my nextpassqueue.
        #     next CHECK
        # delete all queues and checknow
        # put dwin in @(env)dpath and $link
        # while ($link=$d1touch{$link}) {put link in dpath}
        # reverse dpath
        # while ($link=$d1touch{$link}) {put link in dpath}
        #
        
        # work from the beginning
        NODE: foreach $item (@d1passq) #check all of an individual node's links
        {
            CHECK: foreach $link (dgetlinks($item)) #check an individual link 
            {
                $dcoll++ and next CHECK if (exists $d1touch{$link}); #already been here
                $dacoll++ and next CHECK if (exists $davoid{$link}); #don't want it
                $d1touch{$link}=$item; # store who linked us here
                $dwin=$link and last NODE if (exists $d2touch{$link}); #we are DONE!
                push (@d1nextpassq, $link);
            }
        }
        $derror .= qq(<br>No path exists!) and last PASS unless (@d1nextpassq); #what if there's no path?
        @d1passq=@d1nextpassq; @d1nextpassq=();  #clean up our mess.
        
        # work from the end
        NODE: foreach $item (@d2passq) #check all of an individual node's links
        {
            CHECK: foreach $link (dgetlinks($item)) #check an individual link 
            {
                $dcoll++ and next CHECK if (exists $d2touch{$link}); #already been here
                $dacoll++ and next CHECK if (exists $davoid{$link}); #don't want it
                $d2touch{$link}=$item;
                $dwin=$link and last NODE if (exists $d2touch{$link}); #we are DONE!
                push(@d2nextpassq,$link);
            }
        }
        $derror .= qq(<br>No path exists!) and last PASS unless (@d2nextpassq); #what if there's no path?
        @d2passq=@d2nextpassq; @d2nextpassq=();  #clean up our mess.
    }
    
    $dtouch=scalar(keys(%d1touch)) + scalar(keys(%d2touch)) - 1; #number of nodes touched by all this.
                    # --- how efficient is "keys"? it doesn't actually allocate an array does it?
    
    #start at the center and work out. remember, when we hit the end, $link will be 0, so..
    push(@dpath,($link=$dwin));
    push(@dpath,$link) while ($link=$d1touch{$link});
    @dpath=reverse dpath;
    push(@dpath,$link) while ($link=$d2touch{$link});
    
    #that's all.
}
}

# ideally, i would like here for the number of steps to be added to a list somewhere-- probably nothing
# ---  complex, probably just a long file or one-column table containing every single step value from 
# --- every single run of this script. This could be done just so that there could be stats here like 
# --- longest chain length between nodes/average chain length between nodes.

############################# Display half. #############################
# I decided not to go with the whole $str thing, since there's no actual flow control going on..
# instead, i just made a long list, which is strung together. Seems.. cleaner. To me, anyway.

return join("",( 
$query->startform(-method=>'get'),
"<b>Starting node:</b> ",
$query->textfield(-name=>'dsname',  #.. fields contain either the previous value, or random.
                  -default=> ( $query->param('dsname') ? $query->param('dsname') : dgetrandom() ),
		  -size=>50,
		  -maxlength=>80),
"<br><b>Ending node:</b> ",
$query->textfield(-name=>'dgname',
                  -default=> ( $query->param('dgname') ? $query->param('dgname') : dgetrandom() ),
		  -size=>50,
		  -maxlength=>80),
"<p><b>Avoid touching:</b> ",
$query->textfield(-name=>'davoid',
                  -default=>join(",",$query->param('davoid')),
		  -size=>50,
  		  -maxlength=>1000),
"<p>",
$query->submit(-name=>'Go'),
"<hr>",
($derror ? qq(<font color="#CC0000"><b>ERROR:$derror</b></font><p>) : "") ,
(@dpath  ? ("<b>Path taken:</b><ul><li>", 
            join("<li>", map( linkNode($_) , @dpath) ) , # link nodes and join them.. blah
            "</ul>Total steps: <b>", scalar @dpath, "</b><p>") : ""),
($dtouch ? "Search touched <b>$dtouch</b> nodes." : ""),
($dcoll  ? "<br>The path collided with itself <b>$dcoll</b> times" : ""),
($dacoll ? "<br>And collided with the \"Avoid touching\" list <b>$dacoll</b> times." : ".") ));

%]
<p>Can't figure out how to work this thing? Look [Degrees of Everything|here.]

Log in or register to write something here or to contact authors.