",$PROFILES{"desc_$other"},"\n";
} else {
print "[No profile set]
\n"; } if (exists($PROFILES{"long_$USER_ID"}) && exists($PROFILES{"long_$other"})) { my $distrad = great_circle_distance( deg2rad($PROFILES{"long_$USER_ID"}), pi/2-deg2rad($PROFILES{"lat_$USER_ID"}), deg2rad($PROFILES{"long_$other"}), pi/2-deg2rad($PROFILES{"lat_$other"})); my $distnm = $distrad/0.00029088820866572159; my $distsm = $distnm*1.15077945; my $distkm = $distsm*1.609344; print "Distance: $distsm miles, or $distkm kilometers, or ", $distkm*1000/1024, " kibometers. (A kibometer is 1024 meters.)"; } else { print "Cannot calculate distance - you and/or $other don't have a location specified.
\n"; } &show_command_footer(); print "\n"; } sub consider_match() { # No need to consider people with no self-description whatsoever. exists($ATTRIBUTES_DB{$_[0]}) or return; my @their_attributes = split(/,/s, $ATTRIBUTES_DB{$_[0]}); my @their_other_attributes = split(/,/s, $OTHER_ATTRIBUTES_DB{"_$_[0]"}); my @their_other_attributes_forbidden = split(/,/s, $OTHER_ATTRIBUTES_DB{"f_$_[0]"}); my @their_other_attributes_required = split(/,/s, $OTHER_ATTRIBUTES_DB{"r_$_[0]"}); my $x = 0; my $their_forbidden_unclear = 0; my $forbidden_unclear = 0; my $forbidden_absent = 0; my $required_unclear = 0; my $required_present = 0; # my $desirable_absent = 0; # my $desirable_present = 0; # my $undesirable_absent = 0; # my $undesirable_present = 0; my $desirability = 0; my $your_mandatory_score = 0; my $your_mandatory_uncertainty = 0; my $your_desirability = 0; while ($x < $#attribute_descs) { $their_attributes[$x] = 0 if !defined($their_attributes[$x]); $their_other_attributes[$x] = 0 if !defined($their_other_attributes[$x]); $your_attributes[$x] = 0 if !defined($your_attributes[$x]); $other_attributes[$x] = 0 if !defined($other_attributes[$x]); if ($other_attributes_forbidden[$x]) { if ($their_attributes[$x]==1) { # They have something the user doesn't want. return; } elsif ($their_attributes[$x] == 0) { $forbidden_unclear++; } else { # It's a trinary; 0, 1, and -1 should be the only allowed # entries. # Assume they don't have it. $forbidden_absent++; } } elsif ($other_attributes_required[$x]) { # We'll assume that the user doesn't both require and forbid something. # Users who find a way to deserve unreliability. if ($their_attributes[$x] == -1) { return; } elsif ($their_attributes[$x] == 1) { $required_present++; } else { $required_unclear++; } } else { # It's only desirable/non. $desirability += $their_attributes[$x] * $other_attributes[$x]; # if ($other_attributes[$x] == 1) { # if ($their_attributes[$x]==1) { # $desirable_present++; # } elsif ($their_attributes[$x]==-1 { # $desirable_absent++; # } # } elsif ($other_attributes[$x] == -1) { # if ($their_attributes[$x]==1) { # $undesirable_present++; # } elsif ($their_attributes[$x]==-1) { # $undesirable_absent++; # } # } } if ($their_other_attributes_forbidden[$x]) { if ($your_attributes[$x]==1) { return; # They don't want you. } elsif ($your_attributes[$x]==0) { $your_mandatory_uncertainty++; } else { $your_mandatory_score++; } } elsif ($their_other_attributes_required[$x]) { if ($your_attributes[$x]==-1) { return; } elsif ($your_attributes[$x]==0) { $your_mandatory_uncertainty++; } else { $your_mandatory_score++; } } else { $your_desirability += $your_attributes[$x] * $their_other_attributes[$x]; } $x++; } $MANDATORY_SCORE{$_[0]} = $forbidden_absent + $required_present; $YOUR_MANDATORY_SCORE{$_[0]} = $your_mandatory_score; $MANDATORY_UNCERTAINTY{$_[0]} = $forbidden_unclear+$required_unclear; $YOUR_MANDATORY_UNCERTAINTY{$_[0]} = $your_mandatory_uncertainty; $DESIRABILITY{$_[0]} = $desirability; $YOUR_DESIRABILITY{$_[0]} = $your_desirability; } sub score($) { # Returns the score # XXX does not yet factor in distance. return ( $MANDATORY_SCORE{$_[0]}**2 - $MANDATORY_UNCERTAINTY{$_[0]}**2) + $DESIRABILITY{$_[0]} + ( $YOUR_MANDATORY_SCORE{$_[0]}**2 - $YOUR_MANDATORY_UNCERTAINTY{$_[0]}**2) + $YOUR_DESIRABILITY{$_[0]}; } #sub lat($) #{ # if ($_[0] < 0) { # return (0-$_[0]).'S'; # } # return "$_[0]N"; #} # #sub long($) #{ # if ($_[0] < 0) { # return (0-$_[0]).'W'; # } # return "$_[0]E"; #} sub arc_string($$$) { my ($deg,$pos,$neg) = @_; my $ideg = int($deg); my $ret = abs($ideg); if ($deg != $ideg) { my $minsec = abs($deg-$ideg); my $mins = int(sprintf("%.6g",$minsec*60)); $ret .= " ".$mins."'"; if ($mins!=($minsec*60)) { my $secs = int(sprintf("%.1g",(($minsec*60)-$mins)*60)); $ret .= " ".$secs."''" if $secs; } } if ($deg>0) { $ret .= $_[1]; } elsif ($deg<0) { $ret .= $_[2]; } return $ret; } sub long_string($) { return arc_string($_[0],'E','W'); } sub lat_string($) { return arc_string($_[0],'N','S'); } sub latlong_and_distance($) { my $other = $_[0]; my $ret=''; if (exists($PROFILES{"lat_$other"})) { $ret .= lat_string($PROFILES{"lat_$other"}). ' '. long_string($PROFILES{"long_$other"}); } else { return '[unknown]'; } if (exists($PROFILES{"lat_$USER_ID"})) { my $distrad = great_circle_distance( deg2rad($PROFILES{"long_$USER_ID"}), pi/2-deg2rad($PROFILES{"lat_$USER_ID"}), deg2rad($PROFILES{"long_$other"}), pi/2-deg2rad($PROFILES{"lat_$other"})); my $distnm = $distrad/0.00029088820866572159; my $distsm = int($distnm*1.15077945); $ret .= "(Searching using your existing preference settings.)
\n"; my @keys = keys(%ATTRIBUTES_DB); my $key; my $x; for $key (@keys) { &consider_match($key); } &sort_and_show_matches(); print "\n"; dbmclose(%ATTRIBUTES_DB); &unlock_data_file("attributes.db"); dbmclose(%OTHER_ATTRIBUTES_DB); &unlock_data_file("other-attributes.db"); } sub option_requirement_count() { my $x=0; my $ret = 0; while ($x<$#other_attributes) { if ($other_attributes[$x]) { $ret++; } $x++; } return $ret; } sub sanity_check_profile() { my $opt = &option_requirement_count(); $your_profile{'minopt'} = 0 if !defined($your_profile{'minopt'}); if ($your_profile{'minopt'}>$opt) { push(@MINOR_ERRORS, "Minimum optional desirability exceeds your optional desirability range.\n Fixing."); $your_profile{'minopt'} = $opt; } if ($your_profile{'desc'}=~s/20000) { push(@MINOR_ERRORS, "Your profile was too long. It has been truncated. (Removed section:". substr($your_profile{'desc'},20000).")
\n");
substr($your_profile{'desc'}, 20000) = '';
}
}
sub save_your_attributes($)
{
&write_lock_data_file('attributes.db');
dbmopen(%YOUR_ATTRIBUTES_DB, "$DATAPATH/attributes.db", 0666) or
&fatalerror("Unable to dbmopen(attributes.db)\n");
$YOUR_ATTRIBUTES_DB{$USER_ID} = join(',',@your_attributes);
dbmclose(%YOUR_ATTRIBUTES_DB);
&unlock_data_file('attributes.db');
&save_your_profile();
}
sub save_your_profile()
{
&write_lock_data_file('profiles.db');
dbmopen(%PROFILES, "$DATAPATH/profiles.db", 0666) or
&fatalerror("Unable to dbmopen(profiles.db)\n");
&sanity_check_profile();
$PROFILES{"maxunc_$USER_ID"} = $your_profile{'maxunc'} if
defined($your_profile{'maxunc'});
$PROFILES{"minopt_$USER_ID"} = $your_profile{'minopt'} if
defined($your_profile{'minopt'});
$PROFILES{"lat_$USER_ID"} = $your_profile{'lat'} if
(defined($your_profile{'lat'}) && $your_profile{'lat'} ne '');
$PROFILES{"long_$USER_ID"} = $your_profile{'long'} if
(defined($your_profile{'long'}) && $your_profile{'long'} ne '');
$PROFILES{"desc_$USER_ID"} = $your_profile{'desc'} if
defined($your_profile{'desc'});
$PROFILES{"maxdist_$USER_ID"} = $your_profile{'maxdist'} if
(defined($your_profile{'maxdist'}) && $your_profile{'maxdist'} ne '');
dbmclose(%PROFILES);
&unlock_data_file('profiles.db');
}
sub parse_arc($$$)
{
return undef unless defined $_[0];
my ($latin,$posch,$negch) = @_;
my $sign = 1;
if ($latin=~s/$negch//sig) {
return undef if $latin=~/$posch/is;
$sign = -1;
} else {
$latin=~s/$posch//sig;
}
if ($latin=~/^([0-9]+)$/s) {
return $latin*$sign;
} elsif ($latin =~/^(-[0-9]+)$/s) {
return $latin*$sign;
}
if ($latin=~/^([0-9]+)([^0-9]+)(.*?)$/s) {
my $degrees = $1;
my $tail=$3;
$tail=~s/^\s+//si;
$tail=~s/\s+$//si;
if ($tail=~/([0-9]+)'$/s) {
$degrees += $1*(1/60);
} elsif ($tail=~/([0-9]+)'[^0-9]*([0-9]+)(''|")/si) {
my $minutes = $1;
my $seconds = $2;
return ($degrees + ($minutes*(1/60)) + ($seconds*(1/3600))) * $sign;
}
return $degrees * $sign;
}
return undef;
}
sub parse_latitude($)
{
return parse_arc($_[0],'N','S');
}
sub parse_longitude($)
{
return parse_arc($_[0],'E','W');
}
sub set_your_attributes($)
{
&check_login();
my @params = $query->param();
my $param;
for $param (@params) {
if ($param=~/^option_([0-9]+)$/s) {
my $num = $1;
$your_attributes[$num] = $query->param($param);
}
}
$your_profile{'maxunc'} = $query->param('profile_maxunc');
$your_profile{'minopt'} = $query->param('profile_minopt');
$your_profile{'desc'} = $query->param('profile_desc');
$your_profile{'lat'} = parse_latitude($query->param('profile_lat'));
$your_profile{'long'} = parse_longitude($query->param('profile_long'));
$your_profile{'maxdist'} = $query->param('profile_maxdist');
&save_your_attributes();
&success("Your attributes have been updated.\n");
}
sub show_your_attribute($)
{
print "$attribute_descs[$_[0]]:
";
}
sub write_lock_data_file()
{
open("LOCK_$_[0]","<$DATAPATH/$_[0]") or
&fatalerror("Could not open $_[0] for locking\n");
flock("LOCK_$_[0]", &LOCK_EX) or
&fatalerror("Could not lock $_[0]\n");
}
sub read_lock_data_file()
{
open("LOCK_$_[0]","<$DATAPATH/$_[0]") or
&fatalerror("Could not open $_[0] for locking\n");
flock("LOCK_$_[0]", &LOCK_SH) or
&fatalerror("Could not lock $_[0]\n");
}
sub unlock_data_file($)
{
flock("LOCK_$_[0]", &LOCK_UN) or
&fatalerror("Silly error unlocking $_[0]\n");
}
sub load_your_attributes()
{
&read_lock_data_file('attributes.db');
dbmopen(%YOUR_ATTRIBUTE_DB,"$DATAPATH/attributes.db", 0666) or
&fatalerror("Could not open attributes.db\n");
if (exists($YOUR_ATTRIBUTE_DB{$USER_ID})) {
@your_attributes = split(/,/, $YOUR_ATTRIBUTE_DB{$USER_ID});
}
dbmclose(%YOUR_ATTRIBUTE_DB);
&unlock_data_file('attributes.db');
}
sub textarea_clean()
{
my $ret = $_[0];
$ret=~s/Good Sex For Mutants: You
$STYLESHEET