#! perl
#
# prio Daniel Brockman 20030818 prioritizer
#
# Facilitates the prioritization of a list of items.
#
#######################################################
#                                                     #
# Creative Commons Attribution License                #
# http://creativecommons.org/licenses/by/2.5/         #
# The author grants permission to copy or modify,     #
# provided the copier acknowledges the author by name.#
# -- Daniel Brockman, author, 20031018                #
#######################################################
# 
# Usage: prio.pl file 
#
#        User specifies the text file that contains a
#        list of items to prioritize, one item per line.
#        
#        The program will arrange the list of items into
#        pairs and will ask the user to indicate, for each
#        pair of items, which of the two items has 
#        priority.
#       
#        The program then records the items in the file
#        in order by the priorities the user indicated.
#
# General procedure:
# 1st: read in lists of items from file
# 2nd: ask user to prioritize each pair of items
# 3rd: save new prioritization in file
#
# Note: In this implementation, the old file is read,
# a new file is written, then the old file is renamed
# to preserve the original data, and the new file is 
# renamed to take the name of the old file. prio invokes
# the perl function rename() which has platform 
# dependencies and this may raise portability issues.
# 
# Prioritization algorithm:
# 1. We assume the list of items in the file 
# follows an order such that the first 
# item is the one to address first and 
# so has the highest priority, and 
# the last item is the one to address last
# and so has the lowest priority.
# 2. On input, we assign each item a 
# numeric score such that the lowest
# score is associated with the highest 
# priority item. So the score on input
# is the sequence of the items in the
# input file.
# 3. The pair array is a triangular matrix
# such that each element corresponds to 
# a pair of the items, and each element 
# contains the identifying number of the
# higher priority item in the pair.
# 4. We then go through the triangular 
# matrix pair by pair and ask the user 
# to choose which of the pair is the
# higher priority item.
# 5. We then reassign the score of each
# item by counting the number of times
# its identifying number appears in the
# pair array. The most often preferred
# item gets the lowest numeric score
# (equivalent to the highest priority).
# 6. If any two items have the same 
# reassigned score, we arbitrate between
# them by referring to that cell in the 
# matrix associated with that pair of 
# items, and we adjust the reassigned
# scores to reflect the relative 
# priority of the two items. 
# 7. We then sort the items according
# to the scores.
#
# Note: My intuition tells me one might find
# an order of magnitude of efficiency improvement
# in this program, and I have no doubt that one
# could improve the interfacing and the program
# structure. A handy subroutine might handle
# the two-dimensional looping while accepting
# as input the name and arguments of a 2nd subr
# to invoke from the inner loop.

use strict vars;
use strict subs;

my (
	$infile,        # input list file
	$infilo,        # input list file previous
	$outfile,       # output list file scratch
	@item,        # list of items to prioritize
  @deli,        # if $item[x] removed, then $deli[x]=1, =undef otherwise
	@score,        # list of scores corresponding to each item
  @udscore,      # scores of undeleted items
	@pair,         # 2-dim pairs, preferenced
	@mark,         # =undef if pair not considered, =1 otherwise
  $mrkct,        # count of marks
	%sortsc,       # score sorting hash
	$num,          # count of pairs
	$i,$j,$k,$L,   # aux
	$slug,@slug,   # aux
  $flag,         # aux
	$line,         # input line
  $ans,          # user's response
  $safety,       # prevents eternal loops
  $u,            # calculated number of pairs
);

# init
$num=0;

  # open files
  #
	$infile=$ARGV[0];
	if (! -f $infile){
		die "Input file $infile doesnt exist. Usage: $0 filename";
	}
	open(INP,"<",$infile) or die "Cant open input file $infile."
    . "  Usage: $0 filename";

	$outfile=$infile."out";      # output file name
	open(OUT,">",$outfile) or die "Cant open output file $outfile";

# input and edit
@item=<INP> ;      # read items from file

# delete blank lines
for($i=$#item;$i>=0;$i--){      # loop the items
  chomp($item[$i]);            # remove newline
  if($item[$i]=~m/^[\s]*$/){   # detect blank line
    $deli[$i]=1;               # treat as deleted
    next;
  }                           
}
for($i=$#item;$i>=0;$i--){
  print "L121 $i $deli[$i] :$item[$i]:\n";
}

# remove dupes
for($i=$#item;$i>0;$i--){      # loop the items
  if($deli[$i]){next};         # skip deleted items
  for($j=0;$j<$i;$j++){         # loop all items preceding this one
    if($deli[$j]){next};       # skip deleted items
    if($item[$j] eq $item[$i]){  # identical?
      $deli[$i]=1;               # treat as deleted
      last;
    }                           
  }
}




# consider the pairs
for($i=$#item;$i>0;$i--){      # loop the items
  if($deli[$i]){next};         # skip deleted items

  for($j=0;$j<$i;$j++){     # loop all items preceding this one
    if($deli[$j]){next};       # skip deleted items
    
    # initialize the preference array
    $pair[$i][$j]=$j;          # prefer the one earlier in the list
    $num++;                    # count number of pairs
  } # for j
} # for i

srand($slug=(time|$$));  # init random number generator
# print "L158 \$\$:$$ slug:$slug\n";


$mrkct=0;                      # init count of marks
$safety=0;                     # prevent eternal loop
$u=(($#item*$#item-$#item)/2); # calculated number of pairs
  # note: number of pairs in triangle is (($#item*$#item-$#item)/2)
while(
    #$mrkct<(int(0.9*$u)) 
    # and 
    $safety<(1000*$u)
    and $mrkct<$u-2
      ){

  $safety++;                   # count loops
  # we choose randomly so user won't get bored and lose vigilance
  # we choose the $i-value above ($slug) to improve the 
  # anxiety-relief display.
  $i=int(rand(1)*($#item+.99)); # choose ordinate
  # $i=int((1-sqrt(rand(1)))*($#item+.01)); # choose ordinate
  # $i=int(((1-rand(1))**2)*($#item+1-.01)); # choose ordinate
  # $i=int((1-rand(1)**2)*($#item+1-.01)); # choose ordinate
  # $i=int((rand(1))*($#item+1-.01)); # choose ordinate
  # $i=int(sqrt(rand(1))*($#item+1-.01)); # choose ordinate
#   print "AAA slug:$slug i:$i mrkct:$mrkct safety:$safety\n";
  if($i>$#item){$i=$#item};    # max
  if($i<1){$i=1};              # min
  $j=int(rand(1)*($i-.01));        # choose a preceding item
  # $j=int((1-((rand(1))**4))*($i-.01));        # choose a preceding item
  # $j=int(((rand(1))**4)*($i-.01));        # choose a preceding item
  # $j=int(((rand(1))**2)*($i-.01));        # choose a preceding item
  # $j=int((rand(1)**2)*($i-.01));        # choose a preceding item
  # $j=int(rand($i-.01));        # choose a preceding item

  #print "ABB i:$i j:$j\n";

  # query user
  &usetup(\@mark,\$i,\$j,\@deli,\@item,\@pair,\$ans,
    \$mrkct);
  if($ans eq "S"){last};       # save and exit

} # end while mrkct<int


# now finish up remaining choices without randomness
if($ans ne "S"){               # not in save-and-exit mode?
  for($i=$#item;$i>0;$i--){
    if($deli[$i]){next};      # skip deleted items
    for($j=0;$j<$i;$j++){
      if($deli[$j]){next};      # skip deleted items
  
        # query user
        &usetup(\@mark,\$i,\$j,\@deli,\@item,\@pair,\$ans,
          \$mrkct);
        if($ans eq "S"){last};       # save and exit
  
    } # end for j
    if($ans eq "S"){last};       # save and exit
  } # end for i
}


# now we count up the scores
# This might have been done in one pass for quicker 
# system performance, but I did it separately to make
# it more easily understood to the human who will 
# maintain the program, a good tradeoff I think.
#
# init scores
splice(@score,0);

# loop the pair matrix
for($i=$#item;$i>0;$i--){
  if($deli[$i]){next};
  for($j=0;$j<$i;$j++){
    if($deli[$j]){next};
    $score[$pair[$i][$j]]++;      # count em
  } # end for j
} # end for i

# resolve matching scores, break all ties
&tiebreak(\@item,\@score,\@pair,\@deli) ;

# sort the items by score.

# populate sorting hash
for ($i=$#item; $i>=0; $i--) { # item loop
  if($deli[$i]){next};         # skip deleted items
  push( @{$sortsc{$score[$i]}}, $i);  # possible multi
    # See Christiansen & Torkington, "Perl Cookbook",
    # 2nd ed, Sec 5.8 "Hashes with Multiple Values per
    # Key", p. 162.
  push(@udscore,$score[$i]);    # make arr of undel scores
}


# print items sorted by priority
$slug=-1;     # prevent multiprinting tied scores
foreach $j (sort {$b<=>$a} @udscore) {
  if($j != $slug){
    foreach $k (@{$sortsc{$j}}) {
      if($deli[$k]){next};    # skip deleted item
      print OUT "$item[$k]\n";
    }
  }
  $slug=$j;   # remember last score
}

# close and rename files

close(INP);
close(OUT);
rename ($infile,$infile.".prev") || die "Cant rename $infile to $infile\.prev" ;
print "Old input file $infile saved as $infile\.prev .\n";
rename($outfile,$infile) || die "Cant rename $outfile to $infile" ;
print "Saving choices in file $infile .\n";
print "Top priorities recorded in file $infile:\n";
system("head -5 $infile");

# end main


#-----------------------------------------------------
sub tiebreak(\@\@\@\@) {

  # When two or more items have the same score,
  # tiebreak finds which is preferred from the 
  # pair matrix. tiebreak adjusts the values in 
  # the score array.

  # notes:
  # (1) There may exist pathological cases that would
  # cause the algorithm here implemented to fail,
  # but I believe that for almost all practical 
  # purposes, this algorithm will suffice.
  # It can fail for Rock,Scissors,Paper.
  # (2) I'm uncertain whether the outer "$i" for
  # loop is really necessary. Indeed it may add
  # unnecessarily to processing time. This may 
  # be a useful area for investigation and 
  # improvement.
  # (3) Something about this subroutine looks to me
  # technically inefficient, and possibly erroneous in 
  # unusual cases. I suspect there's opportunity for
  # significant improvement toward simplicity and 
  # elegance that might be taken when clear advantage
  # becomes appears, but for now, tempus fugit.

  my (
  $itemr,        # ref to item array
  $scorer,       # ref to score array
  $pairr,        # ref to pair array
  $delir,        # ref to deli array
  )=@_;

  my (
    $i,$j,$k,$L,  # aux
    @itsh,        # array of shadow item numbers
    @scsh,        # array of shadow scores
    @mark,        # array to mark items already considered
    $level,       # score level
    $tiny,        # a tiny number
    $flag,        # flags whether all scores are in
  );

  $tiny=1/(1+(1+$#$itemr)*(1+$#$itemr));
#  print "tiny: $tiny\n";

  # take the items one by one

  for ($i=$#$itemr; $i>0; $i--){   # one by one loop
    if($$delir[$i]){next};          # skip deleted items
    $level=$$scorer[$i];           # the score for this item

    for($L=1;$L<=3;$L++){        # limit=3 passes, avoiding patho case
      $flag=0;                     # assume no tied scores
      for($j=$#$itemr;$j>0;$j--){      # outer pairs loop
        if($$delir[$j]){next};          # skip deleted items
        if($level == $$scorer[$j]){  # found matching score
          for($k=0;$k<$j;$k++){         # inner pairs loop
            if($$delir[$k]){next};        # skip deleted items
  

            if($level == $$scorer[$k]){  # found matching score
              $scsh[$$pairr[$j][$k]]+=$tiny ; # incr score for pref
              $flag=1;             # tied score found
            } # if level scorer k

          } # end inner pairs loop
        } # if level scorer j
      } # end outer pairs loop

      # add shadow scores to main scores
      for($j=$#$itemr;$j>0;$j--){      # items loop
        $$scorer[$j]+=$scsh[$j] ;      # add score
        $scsh[$j]=0;                   # reinit shadow score
      } # end for items loop

      if(!$flag){last};                # escape if no ties found

    } # end for L

  } # end one by one loop

} # end sub tiebreak

#----------------------------------------------------------------


sub usetup (\@\$\$\@\@\@\$\$){

  # manages interaction with user in prioritizing 
  # a pair. This subr exists solely to avoid 
  # repetitive code. Intended for call only from 
  # prio.pl main.
  # sub usetup doesn't change the number of items in item array

my(
  $markr,  # ref to @mark
  $ir,     # ref to $i
  $jr,     # ref to $j
  $delir,  # ref to @deli
  $itemr,  # ref to @item
  $pairr,  # ref to @pair
  $ansr,   # ref to $ansr
  $mkctrr, # ref to $mkctr
  )=@_;

my(
  $k,$L,   # aux
);

  if(!$$markr[$$ir][$$jr]) {  # already considered?

    # note: if already deleted then mark pair
    if(!$$delir[$$ir] and !$$delir[$$jr]) {
  
      # Show Progress to Provide Anxiety Relief
      print "\n";
      print "--------------------------------------------\n";
      for($k=$#$itemr;$k>0;$k--){
        if($$delir[$k]){next};      # skip deleted items
        printf " %3d ",$k ;
        for($L=0;$L<$k;$L++){
          if($$delir[$L]){next};      # skip deleted items
          if($k==$$ir && $L==$$jr){
            print "X";
          }else{
            print  ($$markr[$k][$L]?"o":".") ;
          }
        }
        print "\n";
      }

      # ask user to choose priority
      print("--\[$$mkctrr\]");           # count the decisions
      &pickone($itemr,$pairr,$delir,$ir,$jr,$ansr) ; 
  
      if($ans eq "Q"){       # user wants to quit?
        die "Quitting, abandoning work.";
      }elsif($ans eq "S"){   # user wants to save and exit
        return;
      }
  
    }  # if !$deli
  
  
    $$markr[$$ir][$$jr]=1;       # pair considered
    $$mkctrr++;               # count pairs considered
  
  }
  
} # end sub usetup

#---------------------------------------------------------

sub pickone(\@\@\@\$\$\$) {

# Prompts user to indicate preference of one item or the other.
# Adjusts preference and item arrays appropriately
# intended for call only by prio.pl
# pickone doesn't change the number of items in @$itemr

  my(
    $itemr,                     # ref to item array
    $prefr,                     # ref to pref array
    $delir,                     # ref to deleted items array
    $ir,                        # ref to subscr of one item
    $jr,                        # ref to subscr of 2nd item $j<$i
    $ansr,                      # user's response
    )=@_;

  my(
    $n,$m,$o,           # aux
    $chosen,            # =0 if user made choice, =0 otherwise
  );

  # The lower-numbered item (j) is preferable

  if($$ir<=$$jr){       # error check
    die "Programming error A";
  }


  while(!$chosen){

    # ask user to choose
    print "--------------------------------------------\n";
    print "Item A: @item[$$jr]\n";      
    print "Item B: @item[$$ir]\n";      
    print "\n";

    print "A=item A is higher priority, B=item B is higher,\n"
    . "DA=delete item A from list, DB=delete item B \n"
    . "Q=abandon work and quit, S=save work and exit.\n"
    . "Your choice (A, B, DA, DB, Q, S) <default=A>? " ;
#   read (STDIN,$$ansr,1);
    chomp($$ansr=<STDIN>);

    $$ansr=~s/[\s]+//g;
    if($$ansr eq ""){$$ansr="A"};     # default

    $$ansr=~tr/a-z/A-Z/ ;             # check answer
    $chosen=($$ansr eq "A" or $$ansr eq "B"
      or $$ansr eq "DA" or $$ansr eq "DB" 
      or $$ansr eq "Q" or $$ansr eq "S");

  } # end while not chosen

  if($$ansr eq "A" or $$ansr eq ""){  # user prefers A
    $$prefr[$$ir][$$jr]=$$jr;

  }elsif($$ansr eq "B"){              # user prefers B
    $$prefr[$$ir][$$jr]=$$ir;

  }elsif($$ansr eq "DA"){              # remove A from list
    $$delir[$$jr]=1;

  }elsif($$ansr eq "DB"){              # remove B from list
    $$delir[$$ir]=1;

  }elsif($$ansr eq "Q"){              # user wants to quit
    $$ansr=""; # reset
    while ($$ansr ne "Q" and $$ansr ne "S") {   # confirm quit without save
      print ("Save Work? Answer \"S\" for \"Save\""
        ." or \"Q\" for \"Quit\" without saving work.\n"
        ."S or Q? ");
      chomp($$ansr=<STDIN>);
      $$ansr=~s/[\s]+//g;
      $$ansr=~tr/a-z/A-Z/ ;             # check answer
    }

  } # end user wants to quit
    

  if($$ansr eq "Q" or $$ansr eq "S"){  # user wants out
    return;

  }
}# end sub
#--------------------------------------------------------------