-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
Hi everyone, my first attempt at a QOTW.
It's been interesting looking at how other people have addressed the
same problem, I thought my code was quite Perlish but it seems that's
only by comparison to the generally C-oriented progammers at work...
I've solved this particular quiz both in Perl 5 and in Haskell 98. My
approach in both is actually fairly similar. Don't read the rest of the
e-mail if you're worried about spoilers.
My Perl implementation isn't quite as robust as it could be - I was
focusing more on the actual functionality than tidying up things like
possible bad user input, and I have to admit I've not tested the reading
from stdin at all. That is fairly peripheral to what I see as the main
problem though - I could sort it out if I had the inclination to do so,
as could any halfway awake Perl programmer.
In Perl my solution revolves primarily around abuse of the sort
function. When I need to generate a random alphabet sequence, I simply
take an array with the alphabet in it and run it through sort { (rand)
<=> 0.5 }, which randomly decides if a letter is greater than or equal
to or less than another one. I know sort isn't supposed to be used like
this, but it works, within the limits of the random number generator of
course.
The actual name sorter relies on another abuse of sort, although less of
a one this time, as all I'm doing is calling a subroutine which uses the
ordering of the letters in the random alphabet as the determining factor
when deciding if it should be less than or greater than or equal to.
I'll be the first to admit that it's not as efficient as it could be -
there are a few places I could avoid some unnecessary looping, I think.
The first name/surname problem I avoided by assuming the first word is
the first name, and that everything else is the surname, and just taking
the first word and glueing it to the end.
However, it does work, and I'm quite pleased with that given that it's
my first QOTW. I was attempting to do the final rotation of the array
for the district number by using a couple of array slices, but for some
reason I couldn't get it to work and I have to admit I lost patience,
which is why there's a hideously inefficient backwards iteration
followed by a reverse.
Look at the code for more of the gory details if you're interested -
explaining it all would be rather tedious I think.
Please bear with me for the next part, if you have no interest in
Haskell at all then ignore this, but I love the language and don't get
to use it as often as I would like. I know this is a Perl list, but I do
like to compare languages sometimes and I hope other people do as well.
Now the Haskell version bears some similarities to the Perl version, in
that it resolves primarily around an abuse of Haskell's sortBy function,
which is much like Perl's sort in that it takes a predicate function to
determine the ordering. This function is of type (a -> a -> Ordering)
when on a list containing things of some type a, meaning it takes two
things of type a, and gives back an Ordering value, which is either GT
(greater than), LT (less than) or EQ (equal to).
As with the Perl implementation I had to write a predicate to compare to
characters, and another to compare two words, which is just a wrapper
around the character compare function. The character compare function
works by calculating the values c1i and c2i as the indexes in the
ordering list of the characters c1 and c2 passed to the function to
compare. This is done with the findIndex function, which goes through a
list applying a supplied predicate function until it hits an element
which causes the predicate to become true, at which point it returns the
index. If it doesn't find it, it returns Nothing to indicate failure.
The predicate used is quite simple, just a lamba function (anonymous
subroutine really) which compares two characters after converting them
to uppercase.
Once c1i and c2i are known, the function checks their values to see if
they actually found anything (which is the test for Just x and Just y),
or if they didn't (which is the test for Nothing, which bombs out as
that really shouldn't happen if I was validating the user input
properly). It then returns the appropriate LT, GT or EQ after doing
numeric comparison on the indices.
The whole name compare is pretty simple, it just takes the ordering list
and the two names, and runs through both names simultaneously a
character at a time, checking the characters at each stage and doing the
sensible thing. We can do this using Haskell's convenient
list-manipulation syntax, because strings in Haskell are just lists of
characters anyway.
With the two comparison functions in place, the core of the program is
just a matter of reordering the names to put them surname first, which
is done as with the Perl by simply taking the first word of the name and
putting it on the end, and passing the comparison function to sortBy.
The resulting sorted list of names is passed through a function called
shift, which does the district number rotation in a simple recursive
function definition. This could be more efficient than it is - appending
to the tail of a list in Haskell is an O(N) operation where N is the
length of the list, largely because lists are constructed using the :
list prepend function internally, so the list [1, 2, 3] is actually
(1:(2:(3:[]))). I'm sure you can immediately imagine why appending to
the end is O(N). I could prepend and reverse the list afterwards (which
can be faster, depending on how big your list is, although prepending is
constant time) or use a backwards list type known as a Snoc list, but
that also wasn't necessary to demonstrate the solution. Maybe next time
I'll go for code quality.
The rest of the program is a fairly incomplete implementation of the
required file-reading code, with a woeful lack of error checking. That
kind of thing is surprisingly hard to do in Haskell, but it is good at
the list chopping and other parts which form the core of this week's quiz.
Anyway, if anyone's still awake by now, code attached. elect.pl is the
Perl implementation, elect.hs is the Haskell, there's a dismal lack of
comments especially in the Haskell, which is a shame because that's
where you probably need them the most, but I've got lots to do this
weekend so I feel good about having done both these solutions as it is.
If you want to run the Haskell version, I developed it using the Glasgow
Haskell Compiler version 6.2.1, but I suspect it'll work on any 5.x
version of GHC, and any relatively recent version of Hugs, as it's pure
Haskell 98 with no fancy extensions used. The Perl version, of course,
should work with most versions of Perl 5, I think. Possibly even all of
them.
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.2.2 (Darwin)
Comment: Using GnuPG with Thunderbird - http://enigmail.mozdev.org
iD8DBQFA3eYu0UvYjCBpIlARAjQ7AJ9oTO98kvLDL+WK4k1M/ZLbhJb3RQCgo4dv
IMQBTdmgBBv4bisHBir4flM=
=QFDN
-----END PGP SIGNATURE-----
#!/usr/bin/perl
use warnings;
use strict;
# if true, generate a random letter sequence and write
# to $permutationfile
my $regenerate = 0;
# file to read letter sequence from. If it doesn't
# exist, generate a random sequence and write it there
my $permutationfile = 'randlet.txt';
# district number is 1 upwards
my $districtnumber = 1;
# undef indicates reading from stdin
# otherwise, a filename to read from
my $namefile = undef;
# horrible clunky command-line processing
# the qotw question specifies an evil command-line syntax
# which is far too vague and fuzzy
my $arg = shift;
if($arg eq '-r') {
$regenerate = 1;
$arg = shift;
}
while(defined $arg) {
if(@ARGV == 0) {
$namefile = $arg;
}
elsif(@ARGV == 1) {
$districtnumber = $arg;
}
elsif(@ARGV == 2) {
$permutationfile = $arg;
}
$arg = shift;
}
##
## Generate a random alphabet sequence
##
sub generate_random_sequence() {
my @ALPHABET = qw/A B C D E F G H I J K L M N O P Q R S T U V W X Y Z/;
sort { (rand) <=> 0.5 } @ALPHABET;
}
##
## Find the index of an item in an array
## uses string comparison
## case-insensitive
##
sub index_of($\@) {
my $needle = shift;
my $haystack = shift;
my $i = 0;
foreach (@$haystack) {
return $i if uc($_) eq uc($needle);
$i++;
}
# didn't find it
return;
}
##
## take a name in firstname surnames format
## and turn it into surnames firstname
##
sub normalise_name($) {
my $name = shift;
$name =~ s/(\S+) (.*)/$2 $1/;
$name =~ s/\s//g;
$name;
}
##
## Compare based on the order of list elements
## returns the same kind of thing as cmp would
##
sub specified_letter_compare($$\@) {
my $x = shift;
my $y = shift;
my $order = shift;
my $x_index = index_of $x, @$order;
my $y_index = index_of $y, @$order;
die "'$x' not found in ordering specifier\n" unless defined $x_index;
die "'$y' not found in ordering specifier\n" unless defined $y_index;
return -1 if $x_index < $y_index;
return 0 if $x_index == $y_index;
return 1 if $x_index > $y_index;
}
##
## wrapper around specified_letter_compare which extends
## it to deal with whole names
##
sub specified_name_compare($$\@) {
my $name1 = shift;
my $name2 = shift;
my $order = shift;
my @name1 = split //, normalise_name $name1;
my @name2 = split //, normalise_name $name2;
my $shortestlength = @name1;
$shortestlength = @name2 unless @name1 < @name2;
for(my $i = 0; $i < $shortestlength; $i++) {
my $result = specified_letter_compare($name1[$i], $name2[$i], @$order);
return $result if $result != 0;
}
# at this point the names are identical
# sort the shortest first
return @name1 <=> @name2;
}
my @sequence;
my @names;
unless($regenerate) {
if(open SEQUENCE, '<', $permutationfile) {
my $sequence = <SEQUENCE>;
close SEQUENCE;
chomp $sequence;
@sequence = split //, $sequence;
die "Input sequence '$sequence' not the requisite length (too short)\n" if
@sequence < 26;
die "Input sequence '$sequence' not the requisite length (too long)\n" if
@sequence > 26;
}
else {
@sequence = generate_random_sequence;
}
}
else {
@sequence = generate_random_sequence;
open SEQUENCE, '>', $permutationfile or die "Unable to open $permutationfile
for writing: $!\n";
print SEQUENCE join('', @sequence);
close SEQUENCE;
}
if(defined $namefile) {
open NAMEFILE, '<', $namefile or die "Unable to open list of names $namefile:
$!\n";
while(<NAMEFILE>) {
chomp;
next if /^\s*$/;
push @names, $_;
}
close NAMEFILE;
}
else {
print "Reading names from stdin. Enter one name per line, or '.' by itself to
finish\n";
while(<STDIN>) {
chomp;
last if /^\./;
push @names, $_;
}
}
my @sorted = sort { specified_name_compare($a, $b, @sequence); } @names;
my @rotated;
my $i = $districtnumber - 2;
for(my $count = 0; $count < @sorted; $count++, $i--) {
push @rotated, $sorted[$i];
}
print join("\n", reverse @rotated), "\n";
module Main where
import qualified System as S
import List (findIndex, sortBy)
import Char (toUpper)
main = do
args <- S.getArgs
if length args < 3
then
putStrLn "ERROR: not enough arguments"
else
do
sortednames <- doIt (args!!0) (read $ args!!1) (args!!2)
putStrLn $ showNames sortednames
doIt :: String -> Int -> String -> IO [String]
doIt s d n = do names <- readNames n
perm <- readPerm s
return $ shift (d - 1) $ sortBy (\x y -> specifiedNameCompare
perm (normaliseName x) (normaliseName y)) names
readNames :: String -> IO [String]
readNames f = do content <- readFile f
return $ stripBlanks $ lines content
-- read the file with the permutation list in it
-- a [Char] is the same thing as a String, but we go explicit with it
-- here, because we're treating the permutation list as a list of chars
-- rather than as a whole String
readPerm :: String -> IO [Char]
readPerm f = do content <- readFile f
return $ head $ lines content
stripBlanks :: [String] -> [String]
stripBlanks [] = []
stripBlanks (x:xs) = case length x of
0 -> stripBlanks xs
otherwise -> x:stripBlanks xs
showNames = foldr (\x y -> x ++ "\n" ++ y) []
specifiedCompare :: [Char] -> Char -> Char -> Ordering
specifiedCompare order c1 c2 = let
c1i = findIndex (\x -> (toUpper x)==(toUpper
c1)) order
c2i = findIndex (\x -> (toUpper x)==(toUpper
c2)) order
in
case c1i of
Just x -> case c2i of
Just y -> if x < y
then LT
else if x > y
then GT
else EQ
Nothing -> error "didn't find 2"
Nothing -> error "didn't find 1"
specifiedNameCompare :: [Char] -> String -> String -> Ordering
specifiedNameCompare _ [] _ = LT
specifiedNameCompare _ _ [] = GT
specifiedNameCompare order (x:xs) (y:ys) = case specifiedCompare order x y of
LT -> LT
GT -> GT
EQ -> specifiedNameCompare order
xs ys
normaliseName :: String -> String
normaliseName n = concat $ (\(x:xs) -> xs ++ [x]) $ words n
shift :: Int -> [a] -> [a]
shift _ [] = []
shift 0 xs = xs
shift (n+1) (x:xs) = (shift n xs) ++ [x]
|
