Code Golf: Rotating Maze - language-agnostic

Locked. This question and its answers are locked because the question is off-topic but has historical significance. It is not currently accepting new answers or interactions.
Code Golf: Rotating Maze
Make a program that takes in a file consisting of a maze. The maze has walls given by #. The maze must include a single ball, given by a o and any number of holes given by a #. The maze file can either be entered via command line or read in as a line through standard input. Please specify which in your solution.
Your program then does the following:
1: If the ball is not directly above a wall, drop it down to the nearest wall.
2: If the ball passes through a hole during step 1, remove the ball.
3: Display the maze in the standard output (followed by a newline).
Extraneous whitespace should not be displayed.
Extraneous whitespace is defined to be whitespace outside of a rectangle
that fits snugly around the maze.
4: If there is no ball in the maze, exit.
5: Read a line from the standard input.
Given a 1, rotate the maze counterclockwise.
Given a 2, rotate the maze clockwise.
Rotations are done by 90 degrees.
It is up to you to decide if extraneous whitespace is allowed.
If the user enters other inputs, repeat this step.
6: Goto step 1.
You may assume all input mazes are closed. Note: a hole effectively acts as a wall in this regard.
You may assume all input mazes have no extraneous whitespace.
The shortest source code by character count wins.
Example written in javascript:
http://trinithis.awardspace.com/rotatingMaze/maze.html
Example mazes:
######
#o ##
######
###########
#o #
# ####### #
#### #
#########
###########################
# #
# # # #
# # # ##
# # ####o####
# # #
# #
# #########
# #
######################

Perl, 143 (128) char
172 152 146 144 143 chars,
sub L{my$o;$o.=$/while s/.$/$o.=$&,""/meg;$_=$o}$_.=<>until/
/;{L;1while s/o / o/;s/o#/ #/;L;L;L;print;if(/o/){1-($z=<>)||L;$z-2||L&L&L;redo}}
Newlines are significant.
Uses standard input and expects input to contain the maze, followed by a blank line, followed by the instructions (1 or 2), one instruction per line.
Explanation:
sub L{my$o;$o.="\n"while s/.$/$o.=$&,""/meg;$_=$o}
L is a function that uses regular expressions to rotate the multi-line expression $_ counterclockwise by 90 degrees. The regular expression was used famously by hobbs in my favorite code golf solution of all time.
$_.=<>until/\n\n/;
Slurps the input up to the first pair of consecutive newlines (that is, the maze) into $_.
L;1 while s/o / o/;s/o#/ */;
L;L;L;print
To drop the ball, we need to move the o character down one line is there is a space under it. This is kind of hard to do with a single scalar expression, so what we'll do instead is rotate the maze counterclockwise, move the ball to the "right". If a hole ever appears to the "right" of the ball, then the ball is going to fall in the hole (it's not in the spec, but we can change the # to an * to show which hole the ball fell into). Then before we print, we need to rotate the board clockwise 90 degrees (or counterclockwise 3 times) so that down is "down" again.
if(/o/) { ... }
Continue if there is still a ball in the maze. Otherwise the block will end and the program will exit.
1-($z=<>)||L;$z-2||L+L+L;redo
Read an instruction into $z. Rotate the board counterclockwise once for instruction "1" and three times for instruction "2".
If we used 3 more characters and said +s/o[#*]/ */ instead of ;s/o#/ */, then we could support multiple balls.
A simpler version of this program, where the instructions are "2" for rotating the maze clockwise and any other instruction for rotating counterclockwise, can be done in 128 chars.
sub L{my$o;$o.=$/while s/.$/$o.=$&,""/meg;$_=$o}$_.=<>until/
/;L;{1while s/o / o/+s/o#/ #/;L,L,L;print;if(/o/){2-<>&&L,L;redo}}

GolfScript - 97 chars
n/['']/~{;(#"zip-1%":|3*~{{." o"/"o "*"#o"/"# "*.#>}do}%|~.n*."o"/,(}{;\~(2*)|*~\}/\[n*]+n.+*])\;
This isn't done as well as I hoped (maybe later).
(These are my notes and not an explanation)
n/['']/~ #[M I]
{
;(# #[I c M]
"zip-1%":|3*~ #rotate
{{." o"/"o "*"#o"/"# "*.#>}do}% #drop
|~ #rotate back
.n* #"display" -> [I c M d]
."o"/,( #any ball? -> [I c M d ?]
}{ #d is collected into an array -> [I c M]
;\~(2*)|*~ #rotate
\ #stack order
}/
\[n*]+n.+*])\; #output

Rebmu: 298 Characters
I'm tinkering with with my own experiment in Code Golf language design! I haven't thrown matrix tricks into the standard bag yet, and copying GolfScript's ideas will probably help. But right now I'm working on refining the basic gimmick.
Anyway, here's my first try. The four internal spaces are required in the code as it is, but the line breaks are not necessary:
.fFS.sSC L{#o#}W|[l?fM]H|[l?m]Z|[Tre[wH]iOD?j[rvT]t]
Ca|[st[xY]a KrePC[[yBKx][ntSBhXbkY][ntSBhYsbWx][xSBwY]]ntJskPCmFkSk]
Ga|[rtYsZ[rtXfZ[TaRE[xY]iTbr]iTbr]t]B|[gA|[ieSlFcA[rnA]]]
MeFI?a[rlA]aFV[NbIbl?n[ut[++n/2 TfCnIEfLtBRchCbSPieTHlTbrCHcNsLe?sNsZ]]
gA|[TfCaEEfZfA[prT][pnT]nn]ulBbr JmoADjPC[3 1]rK4]
It may look like a cat was on my keyboard. But once you get past a little space-saving trick (literally saving spaces) called "mushing" it's not so bad. The idea is that Rebmu is not case sensitive, so alternation of capitalization runs is used to compress the symbols. Instead of doing FooBazBar => foo baz bar I apply distinct meanings. FOObazBAR => foo: baz bar (where the first token is an assignment target) vs fooBAZbar => foo baz bar (all ordinary tokens).
When the unmush is run, you get something more readable, but expanded to 488 characters:
. f fs . s sc l: {#o#} w: | [l? f m] h: | [l? m] z: | [t: re [w h] i od?
j [rv t] t] c: a| [st [x y] a k: re pc [[y bk x] [nt sb h x bk y] [nt sb
h y sb w x] [x sb w y]] nt j sk pc m f k s k] g: a| [rt y s z [rt x f z
[t: a re [x y] i t br] i t br] rn t] b: | [g a| [ie s l f c a [rn a]]]
m: e fi? a [rl a] a fv [n: b i bl? n [ut [++ n/2 t: f c n ie f l t br
ch c b sp ie th l t br ch c n s l e? s n s z]] g a| [t: f c a ee f z f
a [pr t] [pn t] nn] ul b br j: mo ad j pc [3 1] r k 4]
Rebmu can run it expanded also. There are also verbose keywords as well (first instead of fs) and you can mix and match. Here's the function definitions with some comments:
; shortcuts f and s extracting the first and second series elements
. f fs
. s sc
; character constants are like #"a", this way we can do fL for #"#" etc
L: {#o#}
; width and height of the input data
W: | [l? f m]
H: | [l? m]
; dimensions adjusted for rotation (we don't rotate the array)
Z: | [t: re [w h] i od? j [rv t] t]
; cell extractor, gives series position (like an iterator) for coordinate
C: a| [
st [x y] a
k: re pc [[y bk x] [nt sb h x bk y] [nt sb h y sb w x] [x sb w y]] nt j
sk pc m f k s k
]
; grid enumerator, pass in function to run on each cell
G: a| [rt y s z [rt x f z [t: a re [x y] i t br] i t br] t]
; ball position function
B: | [g a| [ie sc l f c a [rn a]]]
W is the width function and H is the height of the original array data. The data is never rotated...but there is a variable j which tells us how many 90 degree right turns we should apply.
A function Z gives us the adjusted size for when rotation is taken into account, and a function C takes a coordinate pair parameter and returns a series position (kind of like a pointer or iterator) into the data for that coordinate pair.
There's an array iterator G which you pass a function to and it will call that function for each cell in the grid. If the function you supply ever returns a value it will stop the iteration and the iteration function will return that value. The function B scans the maze for a ball and returns coordinates if found, or none.
Here's the main loop with some commenting:
; if the command line argument is a filename, load it, otherwise use string
m: e fi? a [rl a] a
; forever (until break, anyway...)
fv [
; save ball position in n
n: B
; if n is a block type then enter a loop
i bl? n [
; until (i.e. repeat until)
ut [
; increment second element of n (the y coordinate)
++ n/2
; t = first(C(n))
t: f C n
; if-equal(first(L), t) then break
ie f l t br
; change(C(B), space)
ch C B sp
; if-equal(third(L),t) then break
ie th L t br
; change(C(n), second(L))
ch C n s L
; terminate loop if "equals(second(n), second(z))"
e? s n s z
]
]
; iterate over array and print each line
g a| [t: f c a ee f z f a [pr t] [pn t] nn]
; unless the ball is not none, we'll be breaking the loop here...
ul b br
; rotate according to input
j: mo ad j pc [3 1] r k 4
]
There's not all that much particularly clever about this program. Which is part of my idea, which is to see what kind of compression one could get on simple, boring approaches that don't rely on any tricks. I think it demonstrates some of Rebmu's novel potential.
It will be interesting to see how a better standard library could affect the brevity of solutions!
Latest up-to-date commented source available on GitHub: rotating-maze.rebmu

Ruby 1.9.1 p243
355 353 characters
I'm pretty new to Ruby, so I'm sure this could be a lot shorter - theres probably some nuances i'm missing.
When executed, the path to the map file is the first line it reads. I tried to make it part of the execution arguments (would have saved 3 characters), but had issues :)
The short version:
def b m;m.each_index{|r|i=m[r].index(?o);return r,i if i}end;def d m;x,y=b m;z=x;
while z=z+1;c=m[z][y];return if c==?#;m[z-1][y]=" "; return 1 if c==?#;m[z][y]=?o;end;end;
def r m;m.transpose.reverse;end;m=File.readlines(gets.chomp).map{|x|x.chomp.split(//)};
while a=0;w=d m;puts m.map(&:join);break if w;a=gets.to_i until 0<a&&a<3;
m=r a==1?m:r(r(m));end
The verbose version:
(I've changed a bit in the compressed version, but you get the idea)
def display_maze m
puts m.map(&:join)
end
def ball_pos m
m.each_index{ |r|
i = m[r].index("o")
return [r,i] if i
}
end
def drop_ball m
x,y = ball_pos m
z=x
while z=z+1 do
c=m[z][y]
return if c=="#"
m[z-1][y]=" "
return 1 if c=="#"
m[z][y]="o"
end
end
def rot m
m.transpose.reverse
end
maze = File.readlines(gets.chomp).map{|x|x.chomp.split(//)}
while a=0
win = drop_ball maze
display_maze maze
break if win
a=gets.to_i until (0 < a && a < 3)
maze=rot maze
maze=rot rot maze if a==1
end
Possible improvement areas:
Reading the maze into a clean 2D array (currently 55 chars)
Finding and returning (x,y) co-ordinates of the ball (currently 61 chars)
Any suggestions to improve are welcome.

Haskell: 577 509 527 244 230 228 chars
Massive new approach: Keep the maze as a single string!
import Data.List
d('o':' ':x)=' ':(d$'o':x)
d('o':'#':x)=" *"++x
d(a:x)=a:d x
d e=e
l=unlines.reverse.transpose.lines
z%1=z;z%2=l.l$z
t=putStr.l.l.l
a z|elem 'o' z=t z>>readLn>>=a.d.l.(z%)|0<1=t z
main=getLine>>=readFile>>=a.d.l
Nods to #mobrule's Perl solution for the idea of dropping the ball sideways!

Python 2.6: ~ 284 ~ characters
There is possibly still room for improvement (although I already got it down a lot since the first revisions).
All comments or suggestions more then welcome!
Supply the map file on the command line as the first argument:
python rotating_maze.py input.txt
import sys
t=[list(r)[:-1]for r in open(sys.argv[1])]
while t:
x=['o'in e for e in t].index(1);y=t[x].index('o')
while t[x+1][y]!="#":t[x][y],t[x+1][y]=" "+"o#"[t[x+1][y]>" "];x+=1
for l in t:print''.join(l)
t=t[x][y]=='o'and map(list,(t,zip(*t[::-1]),zip(*t)[::-1])[input()])or 0

C# 3.0 - 650 638 characters
(not sure how newlines being counted)
(leading whitespace for reading, not counted)
using System.Linq;
using S=System.String;
using C=System.Console;
namespace R
{
class R
{
static void Main(S[]a)
{
S m=S.Join("\n",a);
bool u;
do
{
m=L(m);
int b=m.IndexOf('o');
int h=m.IndexOf('#',b);
b=m.IndexOf('#',b);
m=m.Replace('o',' ');
u=(b!=-1&b<h|h==-1);
if (u)
m=m.Insert(b-1,"o").Remove(b,1);
m=L(L(L(m)));
C.WriteLine(m);
if (!u) return;
do
{
int.TryParse(C.ReadLine(),out b);
u=b==1|b==2;
m=b==1?L(L(L(m))):u?L(m):m;
}while(!u);
}while(u);
}
static S L(S s)
{
return S.Join("\n",
s.Split('\n')
.SelectMany(z => z.Select((c,i)=>new{c,i}))
.GroupBy(x =>x.i,x=>x.c)
.Select(g => new S(g.Reverse().ToArray()))
.ToArray());
}
}
}
Reads from commandline, here's the test line I used:
"###########" "#o #" "# ####### #" "#### #" " #########"
Relied heavily on mobrule's Perl answer for algorithm.
My Rotation method (L) can probably be improved.
Handles wall-less case.

Related

Cython. Out of bounds error

I have written the following cython code to be used with the analysis of my research.
def jumprate(np.ndarray[FTYPE_t, ndim=1] X ,np.ndarray[LTYPE_t, ndim=1] V):
cdef np.ndarray J = np.zeros([X.shape[0]], dtype=LTYPE)
cdef np.ndarray O = np.zeros([X.shape[0]], dtype=LTYPE)
cdef np.ndarray Vel = np.zeros([X.shape[0]], dtype=FTYPE)
cdef long j=0 # index of J
cdef long o=0# index of O
cdef long k = 0 # index of X
cdef long l = 0 # counts length of sequence of same velocity sign
cdef long L = V.shape[0]/3
cdef int jumpstart = 1
cdef int jumpend = 1
cdef long S0 = 0
while k < L: # run over position array
if V[k]==V[k-1]: # might be a start of jump
jumpstart = k # Also where last oscilation ended
S0 = V[k]
while V[k]==S0: # As long as velocity sign doesn't change we might be in a jump
l += 1 # Count sequences length
k += 1 # Update position in array
if int(X[jumpstart]) != int(X[k]): # If start end ending point of sequence are
# in different grid squares, it's a jump
J[j] = l # Append jump length to list
j += 1
Vel[j] = (jumpstart-jumpend)/100
O[o] = abs((jumpend-jumpstart)) # Append oscilation length to list
o += 1
l = 0
jumpend = k # mark where last jump ended (also where new oscilation starts)
k+=1
return J,O,Vel
Notice in the definition of L at the 9th line the division by 3. I inserted it after receiving the following error at runtime
while V[k]==S0: # ...
IndexError: Out of bounds on buffer access (axis 0)
which sort of solved the problem. However, the array's X,V passed to the function have 99990 elements in them, and this solution means only the first 33330 are used. At first i though i should simply change the type from int to long but it did not help.
Can anyone suggest a remedy for the problem?
Those who are interested in the purpose of the code, it is meant to follow the trajectory of an atom (the array X), which oscillates in a potential well some times, and jumps from one well to another at other times. The function "jumprate" returns two arrays which holds the lengths (in time) of the alternating jumping and oscillatory motion sequences.
k is initialized with 0, and you are trying to access V[k -1] of a numpy array in
while k < L: # run over position array
if V[k]==V[k-1]: # might be a start of jump

Code Golf: Build Me an Arc

Locked. This question and its answers are locked because the question is off-topic but has historical significance. It is not currently accepting new answers or interactions.
Challenge
The shortest program by character count that accepts standard input of the form X-Y R, with the following guarantees:
R is a non-negative decimal number less than or equal to 8
X and Y are non-negative angles given in decimal as multiples of 45° (0, 45, 90, 135, etc.)
X is less than Y
Y is not 360 if X is 0
And produces on standard output an ASCII "arc" from the starting angle X to the ending angle Y of radius R, where:
The vertex of the arc is represented by o
Angles of 0 and 180 are represented by -
Angles of 45 and 225 are represented by /
Angles of 90 and 270 are represented by |
Angles of 135 and 315 are represented by \
The polygonal area enclosed by the two lines is filled with a non-whitespace character.
The program is not required to produce meaningful output if given invalid input. Solutions in any language are allowed, except of course a language written specifically for this challenge, or one that makes unfair use of an external utility. Extraneous horizontal and vertical whitespace is allowed in the output provided that the format of the output remains correct.
Happy golfing!
Numerous Examples
Input:
0-45 8
Output:
/
/x
/xx
/xxx
/xxxx
/xxxxx
/xxxxxx
/xxxxxxx
o--------
Input:
0-135 4
Output:
\xxxxxxxx
\xxxxxxx
\xxxxxx
\xxxxx
o----
Input:
180-360 2
Output:
--o--
xxxxx
xxxxx
Input:
45-90 0
Output:
o
Input:
0-315 2
Output:
xxxxx
xxxxx
xxo--
xxx\
xxxx\
Perl, 235 211 225 211 207 196 179 177 175 168 160 156 146 chars
<>=~/-\d+/;for$y(#a=-$'..$'){print+(map$_|$y?!($t=8*($y>0)+atan2(-$y,$_)/atan2 1,1)&-$&/45==8|$t>=$`/45&$t<=-$&/45?qw(- / | \\)[$t%4]:$":o,#a),$/}
Perl using say feature, 161 149 139 chars
$ echo -n '<>=~/-\d+/;for$y(#a=-$'"'"'..$'"'"'){say map$_|$y?!($t=8*($y>0)+atan2(-$y,$_)/atan2 1,1)&-$&/45==8|$t>=$`/45&$t<=-$&/45?qw(- / | \\)[$t%4]:$":o,#a}' | wc -c
139
$ perl -E '<>=~/-\d+/;for$y(#a=-$'"'"'..$'"'"'){say map$_|$y?!($t=8*($y>0)+atan2(-$y,$_)/atan2 1,1)&-$&/45==8|$t>=$`/45&$t<=-$&/45?qw(- / | \\)[$t%4]:$":o,#a}'
Perl without trailing newline, 153 143 chars
<>=~/-\d+/;for$y(#a=-$'..$'){print$/,map$_|$y?!($t=8*($y>0)+atan2(-$y,$_)/atan2 1,1)&-$&/45==8|$t>=$`/45&$t<=-$&/45?qw(- / | \\)[$t%4]:$":o,#a}
Original version commented:
$_=<>;m/(\d+)-(\d+) (\d+)/;$e=$1/45;$f=$2/45; # parse angles and radius, angles are 0-8
for$y(-$3..$3){ # loop for each row and col
for$x(-$3..$3){
$t=atan2(-$y,$x)/atan2 1,1; # angle of this point
$t+=8if($t<0); # normalize negative angles
#w=split//,"-/|\\"x2; # array of ASCII symbols for enclosing lines
$s.=!$x&&!$y?"o":$t==$e||$t==$f?$w[$t]:$t>$e&&$t<$f?"x":$";
# if it's origin -> "o", if it's enclosing line, get symbol from array
# if it's between enclosing angles "x", otherwise space
}
$s.=$/;
}
print$s;
EDIT 1: Inlined sub, relational and equality operators return 0 or 1.
EDIT 2: Added version with comments.
EDIT 3: Fixed enclosing line at 360º. Char count increased significantly.
EDIT 4: Added a shorter version, bending the rules.
EDIT 5: Smarter fix for the 360º enclosing line. Also, use a number as fill. Both things were obvious. Meh, I should sleep more :/
EDIT 6: Removed unneeded m from match operator. Removed some semicolons.
EDIT 7: Smarter regexp. Under 200 chars!
EDIT 8: Lots of small improvements:
Inner for loop -> map (1 char)
symbol array from split string -> qw (3 chars)
inlined symbol array (6 chars, together with the previous improvement 9 chars!)
Logical or -> bitwise or (1 char)
Regexp improvement (1 char)
Use arithmethic for testing negative angles, inspired by Jacob's answer (5 chars)
EDIT 9: A little reordering in the conditional operators saves 2 chars.
EDIT 10: Use barewords for characters.
EDIT 11: Moved print inside of loop, inspired by Lowjacker's answer.
EDIT 12: Added version using say.
EDIT 13: Reuse angles characters for fill character, as Gwell's answer does. Output isn't as nice as Gwell's though, that would require 5 additional chars :) Also, .. operator doen't need parentheses.
EDIT 14: Apply regex directly to <>. Assign range operator to a variable, as per Adrian's suggestion to bta's answer. Add version without the final newline. Updated say version.
EDIT 15: More inlining. map{block}#a -> map expr,#a.
Lua, 259 characters
Slightly abuses the non-whitespace character clause to produce a dazzling display and more importantly save strokes.
m=math i=io.read():gmatch("%d+")a=i()/45 b=i()/45 r=i()for y=r,-r,-1 do for x=-r,r do c=m.atan2(y,x)/m.pi*4 c=c<0 and c+8 or c k=1+m.modf(c+.5)io.write(x==0 and y==0 and'o'or c>=a and c<=b and('-/|\\-/|\\-'):sub(k,k)or c==0 and b==8 and'-'or' ')end print()end
Input: 45-360 4
\\\|||///
\\\|||//
\\\\|//
--\\|/
----o----
--//|\\--
////|\\\\
///|||\\\
///|||\\\
Able to handle odd angles
Input: 15-75 8
|/////
|//////
|//////
|//////
///////
|//////-
////---
//-
o
MATLAB, 188 chars :)
input '';[w x r]=strread(ans,'%d-%d%d');l='-/|\-/|\-';[X Y]=meshgrid(-r:r);T=atan2(-Y,X)/pi*180;T=T+(T<=0)*360;T(T>w&T<x)=-42;T(T==w)=-l(1+w/45);T(T==x)=-l(1+x/45);T(r+1,r+1)=-'o';char(-T)
Commented code:
%%# Get the string variable (enclose in quotes, e.g. '45-315 4')
input ''
%%# Extract angles and length
[w x r]=strread(ans,'%d-%d%d');
%%# Store characters
l='-/|\-/|\-';
%%# Create the grid
[X Y]=meshgrid(-r:r);
%%# Compute the angles in degrees
T=atan2(-Y,X)/pi*180;
%%# Get all the angles
T=T+(T<=0)*360;
%# Negative numbers indicate valid characters
%%# Add the characters
T(T>w&T<x)=-42;
T(T==w)=-l(1+w/45);
T(T==x)=-l(1+x/45);
%%# Add the origin
T(r+1,r+1)=-'o';
%%# Display
char(-T)
Mathematica 100 Chars
Out of competition because graphics are too perfect :)
f[x_-y_ z_]:=Graphics#Table[
{EdgeForm#Red,Disk[{0,0},r,{x °,y °}],{r,z,1,-1}]
SetAttributes[f,HoldAll]
Invoke with
f[30-70 5]
Result
alt text http://a.imageshack.us/img80/4294/angulosgolf.png
alt text http://a.imageshack.us/img59/7892/angulos2.png
Note
The
SetAttributes[f, HoldAll];
is needed because the input
f[a-b c]
is otherwise interpreted as
f[(a-b*c)]
GNU BC, 339 chars
Gnu bc because of read(), else and logical operators.
scale=A
a=read()/45
b=read()/45
c=read()
for(y=c;y>=-c;y--){for(x=-c;x<=c;x++){if(x==0)if(y<0)t=-2else t=2else if(x>0)t=a(y/x)/a(1)else if(y<0)t=a(y/x)/a(1)-4else t=a(y/x)/a(1)+4
if(y<0)t+=8
if(x||y)if(t==a||t==b||t==b-8){scale=0;u=(t%4);scale=A;if(u==0)"-";if(u==1)"/";if(u==2)"|";if(u==3)"\"}else if(t>a&&t<b)"x"else" "else"o"};"
"}
quit
MATLAB 7.8.0 (R2009a) - 168 163 162 characters
Starting from Jacob's answer and inspired by gwell's use of any non-whitespace character to fill the arc, I managed the following solution:
[w x r]=strread(input('','s'),'%d-%d%d');
l='o -/|\-/|\-';
X=meshgrid(-r:r);
T=atan2(-X',X)*180/pi;
T=T+(T<=-~w)*360;
T(T>x|T<w)=-1;
T(r+1,r+1)=-90;
disp(l(fix(3+T/45)))
And some test output:
>> arc
0-135 4
\||||////
\|||///-
\||//--
\|/---
o----
I could reduce it further to 156 characters by removing the call to disp, but this would add an extra ans = preceding the output (which might violate the output formatting rules).
Even still, I feel like there are some ways to reduce this further. ;)
Ruby, 292 276 186 chars
x,y,r=gets.scan(/\d+/).map{|z|z.to_i};s=(-r..r);s.each{|a|s.each{|b|g=Math::atan2(-a,b)/Math::PI*180/1%360;print a|b==0?'o':g==x||g==y%360?'-/|\\'[g/45%4].chr: (x..y)===g ?'*':' '};puts}
Nicer-formatted version:
x, y, r = gets.scan(/\d+/).map{|z| z.to_i}
s = (-r..r)
s.each {|a|
s.each {|b|
g = (((Math::atan2(-a,b) / Math::PI) * 180) / 1) % 360
print ((a | b) == 0) ? 'o' :
(g == x || g == (y % 360)) ? '-/|\\'[(g / 45) % 4].chr :
((x..y) === g) ? '*' : ' '
}
puts
}
I'm sure someone out there who got more sleep than I did can condense this more...
Edit 1: Switched if statements in inner loop to nested ? : operator
Edit 2: Stored range to intermediate variable (thanks Adrian), used stdin instead of CLI params (thanks for the clarification Jon), eliminated array in favor of direct output, fixed bug where an ending angle of 360 wouldn't display a line, removed some un-needed parentheses, used division for rounding instead of .round, used modulo instead of conditional add
Ruby, 168 characters
Requires Ruby 1.9 to work
s,e,r=gets.scan(/\d+/).map &:to_i;s/=45;e/=45;G=-r..r;G.map{|y|G.map{|x|a=Math.atan2(-y,x)/Math::PI*4%8;print x|y!=0?a==s||a==e%8?'-/|\\'[a%4]:a<s||a>e ?' ':8:?o};puts}
Readable version:
start, _end, radius = gets.scan(/\d+/).map &:to_i
start /= 45
_end /= 45
(-radius..radius).each {|y|
(-radius..radius).each {|x|
angle = Math.atan2(-y, x)/Math::PI * 4 % 8
print x|y != 0 ? angle==start || angle==_end%8 ? '-/|\\'[angle%4] : angle<start || angle>_end ? ' ' : 8 : ?o
}
puts
}
Perl - 388 characters
Since it wouldn't be fair to pose a challenge I couldn't solve myself, here's a solution that uses string substitution instead of trigonometric functions, and making heavy use of your friendly neighbourhood Perl's ability to treat barewords as strings. It's necessarily a little long, but perhaps interesting for the sake of uniqueness:
($x,$y,$r)=split/\D/,<>;for(0..$r-1){$t=$r-1-$_;
$a.=L x$_.D.K x$t.C.J x$t.B.I x$_."\n";
$b.=M x$t.F.N x$_.G.O x$_.H.P x$t."\n"}
$_=$a.E x$r.o.A x$r."\n".$b;$x/=45;$y/=45;$S=' ';
sub A{$v=$_[0];$x==$v||$y==$v?$_[1]:$x<$v&&$y>$v?x:$S}
sub B{$x<=$_[0]&&$y>$_[0]?x:$S}
#a=!$x||$y==8?'-':$S;
push#a,map{A$_,'\\'.qw(- / | \\)[$_%4]}1..7;
push#a,!$x?x:$S,map{B$_}1..7;
eval"y/A-P/".(join'',#a)."/";print
All newlines are optional. It's fairly straightforward:
Grab user input.
Build the top ($a) and bottom ($b) parts of the pattern.
Build the complete pattern ($_).
Define a sub A to get the fill character for an angle.
Define a sub B to get the fill character for a region.
Build an array (#a) of substitution characters using A and B.
Perform the substitution and print the results.
The generated format looks like this, for R = 4:
DKKKCJJJB
LDKKCJJBI
LLDKCJBII
LLLDCBIII
EEEEoAAAA
MMMFGHPPP
MMFNGOHPP
MFNNGOOHP
FNNNGOOOH
Where A-H denote angles and I-P denote regions.
(Admittedly, this could probably be golfed further. The operations on #a gave me incorrect output when written as one list, presumably having something to do with how map plays with $_.)
C# - 325 319 chars
using System;class P{static void Main(){var s=Console.ReadLine().Split(' ');
var d=s[0].Split('-');int l=s[1][0]-48,x,y,r,a=int.Parse(d[0]),b=int.Parse(d[1]);
for(y=l;y>=-l;y--)for(x=-l;x<=l;)Console.Write((x==0&&y==0?'o':a<=(r=((int)
(Math.Atan2(y,x)*57.3)+360)%360)&&r<b||r==b%360?
#"-/|\"[r/45%4]:' ')+(x++==l?"\n":""));}}
Newlines not significant.
Sample input/output
45-180 8
\||||||||////////
\\|||||||///////
\\\||||||//////
\\\\|||||/////
\\\\\||||////
\\\\\\|||///
\\\\\\\||//
\\\\\\\\|/
--------o
135-360 5
\
\\
\\\
\\\\
\\\\\
-----o-----
----/|\\\\\
---//||\\\\
--///|||\\\
-////||||\\
/////|||||\
Java - 304 chars
class A{public static void main(String[]a){String[]b=a[0].split("-");int e=new Integer(b[1]),r=new Integer(a[1]),g,x,y=r;for(;y>=-r;y--)for(x=-r;x<=r;)System.out.print((x==0&y==0?'o':new Integer(b[0])<=(g=((int)(Math.atan2(y,x)*57.3)+360)%360)&g<e|g==e%360?"-/|\\".charAt(g/45%4):' ')+(x++<r?"":"\n"));}}
More readable version:
class A{
public static void main(String[]a){
String[]b=a[0].split("-");
int e=new Integer(b[1]),r=new Integer(a[1]),g,x,y=r;
for(;y>=-r;y--)for(x=-r;x<=r;)System.out.print((
x==0&y==0
?'o'
:new Integer(b[0])<=(g=((int)(Math.atan2(y,x)*57.3)+360)%360)&g<e|g==e%360
?"-/|\\".charAt(g/45%4)
:' '
)+(x++<r?"":"\n"));
}
}
C (902 byte)
This doesn't use trigonometric functions (like the original perl version), so it's quite ``bloated''. Anyway, here is my first code-golf submission:
#define V(r) (4*r*r+6*r+3)
#define F for(i=0;i<r;i++)
#define C ;break;case
#define U p-=2*r+2,
#define D p+=2*r+2,
#define R *++p=
#define L *--p=
#define H *p='|';
#define E else if
#define G(a) for(j=0;j<V(r)-1;j++)if(f[j]==i+'0')f[j]=a;
#define O(i) for(i=0;i<2*r+1;i++){
main(int i,char**v){char*p,f[V(8)];
int j,m,e,s,x,y,r;p=*++v;x=atoi(p);while(*p!=45)p++;
char*h="0123";y=atoi(p+1);r=atoi(*++v);
for(p=f+2*r+1;p<f+V(r);p+=2*r+2)*p=10;
*(p-2*r-2)=0;x=x?x/45:x;y/=45;s=0;e=2*r;m=r;p=f;O(i)O(j)
if(j>e)*p=h[0];E(j>m)*p=h[1];E(j>s)*p=h[2];else*p=h[3];p++;}
if(i+1==r){h="7654";m--;e--;}E(i==r){s--;}E(i>r){s--;e++;}
else{s++;e--;}p++;}for(p=f+V(r)/2-1,i=0;i<r;i++)*++p=48;
for(i=0;i<8;i++)if(i>=x&&i<y){G(64);}else G(32);
y=y==8?0:y;q:p=f+V(r)/2-1;*p='o';switch(x){
C 0:F R 45 C 1:F U R 47 C 2:F U H C 3:F U L 92
C 4:F L 45 C 5:F D L 47 C 6:F D H C 7:F D R 92;}
if(y!=8){x=y;y=8;goto q;}puts(f);}
also, the #defines look rather ugly, but they save about 200 bytes so I kept them in, anyway. It is valid ANSI C89/C90 and compiles with very few warnings (two about atoi and puts and two about crippled form of main).

Code Golf: Who has the best poker hand?

Locked. This question and its answers are locked because the question is off-topic but has historical significance. It is not currently accepting new answers or interactions.
I love challenges like this, I'll hopefully submit my answer soon.
Which player has the best 7 card hand?
Given an unordered list of 9 cards (separated by a space), work out which player has the best poker hand. Here is a list of poker hand rankings. Example input:
2C 5H AS KS 2D 4D QD KH 3S
(ie: [[2C 5H] [AS KS] [2D 4D QD KH 3S]])
First 2 cards in the array represent player 1's hand, second 2 in the array represent player 2's hand. The last 5 cards represent the community cards, cards both players share. In effect, both players have 7 cards, and you must determine which player has the best 5 card poker hand.
A card is defined as a string, with the first character representing the card value, and the second value representing the suit. Always upper-case. No card may appear twice.
The function will calculate if the hand is a draw or a win to either player. It will ouput the totals at the end of the input. The output format is defined later on in this post.
Examples
2C 5H AS KS 2D 4D QD KH 3S
(ie: [[2C 5H] [AS KS] [2D 4D QD KH 3S]])
Player 2 wins this hand. Player 1 has a pair of 2's, player 2 has a pair of kings.
5S 6S 8H 9D 7S 8S JH TS 2H
(ie: [[5S 6S] [8H 9D] [7S 8S JH TS 2H]])
Player 1 wins this hand Player 1 has a flush, player 2 has a straight.
2S 2H AC AS 2C AH 9H TS 2D
(ie: [[2S 2H] [AC AS] [2C AH 9H TS 2D]])
Player 1 wins this hand. Player 1 has quads, player 2 has a full house
5S 6S 2D 4D 9S AS KD JC 9D
(ie: [[5S 6S] [2D 4D] [9S AS KD JC 9D]])
A draw. Both players have Ace high.
More Info
Thanks to mgroves for the following link to Project Euler which has a similar problem:
http://projecteuler.net/index.php?section=problems&id=54
Test Data
We will use the Project Euler test data:
http://projecteuler.net/project/poker.txt
Your solution should accept that text file as input, and output a total of wins and draws.
Example Output
Output must be in this format:
1: 45
2: 32
D: 12
Player 1 won 45 hands, player 2 won 32 hands, and there were 12 draws. (Not actual results)
Rules
Doesn't have to return the winning hand type, only WHO won if anyone
Card list input has no particular order
No card appears twice in the input
Input is always uppercase
Takes the Project Euler test data as an input
Outputs a count, of which player won the most hands and total draws in given format above
Perl, 414 398 370/458 344/416 char
Line breaks are not significant.
%M=map{$_,$Z++}0..9,T,J,Q,K,A;sub N{/.$/;$M{$`}.$&}
sub B{$s=#p=();
for$m(#_){$m-$_||($s+=2,++$p[$m])for#_}
#_=sort{$p[$b]-$p[$a]||$b-$a}#_;
$s=23 if$s<11&&($_[0]-$_[4]<5||$_[0]-$_[1]>8&&push#_,shift);
"#_"=~/.$/;$s+=14*(4<grep/$&/,#_);
$s=100*$s+$_ for#_;$s}
++$X{B((#c=map{N}split)[0..4])<=>B(#c[5..9])}for<>;
printf"1: %d\n2: %d\nD: %d\n",#X{1,-1,0}
This solves the "10 card" problem (10 cards are dealt, player 1 has the first 5 cards and player 2 has the second 5 cards).
The first section defines a subroutine N that can transform each card so that it has a numerical value. For non-face cards, this is a trivial mapping (5H ==> 5H) but it does transform the face cards (KC => 13C, AD => 14D).
The last section parses each line of input into cards, transforms the cards to contain numerical values, divides the cards into separate hands for the two players, and analyzes and compares those hands. Every hand increments one element of the hash %X. When all the input is parsed, %X contains the number of hands won by player 1, won by player 2, or ties.
The middle section is a subroutine that takes a set of five cards as input and produces a
12-digit number with the property that stronger poker hands will have higher-valued numbers. Here's how it works:
for$m(#_){$m-$_||($s+=2,++$p[$m])for#_}
This is the "pair" detector. If any two cards have the same numerical value, increment a hash element for one of the cards and increase the "score" variable $s by two. Note that we will end up comparing each card to itself, so $s will be at least 10 and $p[$x] will be at least one for every card $x. If the hand contains three of a kind, then those three cards will match with the other two cards -- it will be like there are 9 matches among those three cards and the "score" will be at least 18.
#_=sort{$p[$b]-$p[$a]||$b-$a}#_;
Sort the cards by (1) the number of times that card is part of a "pair" and (2) the value of the card. Thus in a hand with two 7's and two 3's, the two 7's will appear first, followed by the two 3's, followed by the kicker. In a hand with two 7's and three 3's, the three 3's will be first followed by the two 7's. The goal of this ordering is to distinguish two hands that have the same score -- a hand with a pair of 8's and a hand with a pair of 7's both have one pair, but we need to be able to tell that a pair of 8's is better.
$s=23 if$s<11&&($_[0]-$_[4]<5||$_[0]-$_[1]>8&&push#_,shift);
This line is the "straight" detector. A straight is worth 23 points and occurs when there are no pairs in the hand ($s<11 means only 5 "pairs" - each card matching with itself - were found) and either (1) the value of the highest card is exactly four more than the value of the lowest card ($_[0]-$_[4]==4), or (2) the highest value card is an Ace and the next highest card is a 5 ($_[0]-$_[1]==9), which means the hand has an A-2-3-4-5 straight. In the latter case, the Ace is now the least valuable card in the hand, so we manipulate #_ to reflect that (push#_,shift)
"#_"=~/.$/;$s+=14*(4<grep/$&/,#_);
This line is the flush detector. A flush is worth 14 more points and occurs when the last character is the same for each card. The first expression ("#_"=~/.$/) has the side effect of setting $& to the last character (the suit) of the last card in the hand. The final expression (4<grep/$&/,#_) will be true if and only if all elements of #_ have the same last character.
$s=100*$s+$_ for#_;$s}
Creates and returns a value that begins with the hand's score and then contains the values of the cards, in order of the card's importance. Scores for the various hands will be
Hand Score
---------- ------
High card 10 (each card matches itself for two points)
One pair 14 (2 additional matches)
Two pair 18 (4 additional matches)
Three of a kind 22 (6 additional matches)
Straight 23 (no pair, but 23 points for straight)
Flush 24 (no pair, but 14 additional points for the flush)
Full house 26 (8 additional matches)
4 of a kind 34 (12 additional matches)
Straight flush 37 (23 + 14 points)
which is consistent with the rules of poker. Hands with the same score can be distinguished by the values of the hand's cards, in order of importance to the hand, all the way down to the least valuable card in the hand.
The solution to the 9 card problem (two cards to player 1, two cards to player 2, the players share the next 5 cards and build their best 5 card hand) needs about 70 more strokes to choose the best 5 card hand out of the 7 cards available to each player:
%M=map{$_,$Z++}0..9,T,J,Q,K,A;sub N{/./;$M{$&}.$'}
sub A{my$I;
for$k(0..41){#d=#_;splice#d,$_,1for$k%7,$k/7;$s=#p=();
for$m(grep$_=N,#d){$m-$_||($s+=2,$p[$m]++)for#d}
#d=sort{$p[$b]-$p[$a]||$b-$a}#d;
$s=23 if$s<11&&($d[0]-$d[4]<5||$d[0]-$d[1]>8&&push#d,shift#d);
"#d"=~/.$/;$s+=14*(4<grep/$&/,#d);
$s=100*$s+$_ for#d;
$I=$s if$s>$I}$I}
++$X{A((#c=split)[0,1,4..8])<=>A(#c[2..8])}for<>;
printf"1: %d\n2: %d\nD: %d\n",#X{1,-1,0}
GolfScript - 151/187 chars
This program works on an input list of 10 cards per line, i.e. two 5 card hands.
n%0.#{3/5/{[zip~;.&,(!15*\[{n),*"TJQKA"+?}/]:|$),-4>=14*+1|{.2\?|#-,5\-.49?#*#+\.+#+\}/.16445=13*#+\]}%.~={0):0;;}{~>.!#+\#+\}if}/"1: "##n"2: "#n"D: "0
This program works on an input list of 9 cards per line, of the format described in the specifications.
n%0.#{3/.4>:D;2/2<{D+.{3/1$^.{3/1$^[zip~;.&,(!15*\[{n),*"TJQKA"+?}/]$:|),-4>=14*+1|{.2\?|#-,5\-.49?#*#+\.+#+\}/.16445=13*#+\]}%\;~}%$-1=\;}%.~={0):0;\(\}*~>.!#+\#+\}/"1: "##n"2: "#n"D: "0
Haskell: 793 796 806 826 864 904 901 880 863
Since the text file is inconsistent with 9 card hands, I'm just reading a line from the console and outputting who wins.
Bugfixes:
Ace now counts lower than a 2 in an ace-low run.
Comparing full houses fixed (again :D).
Guarantees that the best version of a given hand type is chosen. For example, if a player can choose between a 2-6 run and a 3-7 run, the 3-7 run is chosen (flushes aside).
Now shorter than the PHP solution!
Golfed:
import Data.List
(%)=mod
m=map
y=foldr1
t=0<1
z=13
w=[0,1,2,3,12]
n&x|length x<n=[]|t=take n x
b?x|b=x|t=[]
n!k= \c->e(n&m(%k)c)?(n&c)
e[]=1<1
e(x:y)=all(x==)y
k q c|any null[q c,p$c\\q c]=[]|t=q c
f=5!4
s c=(sort(m(%z)c)`elem`w:[[n..n+4]|n<-[0..8]])?c
r=3!z
p=2!z
g x y|c x y<2=x|t=y
q x(_,[])=x
q _ y=y
b h=y q$m($h)$zipWith(\t f->(,)t.y g.m(f.take 5).permutations)[1..][1!1,p,k p,r,s,f,k r,4!z,s.f]
h=reverse.a.m(%z)
a v|w\\v==[]=[-1..3]|t=sort v
c x y=o(h x)$h y
o[](_:_)=2
o[]_=0
o _[]=1
o(a:b)(k:d)|a>k=1|a<k=2|t=o b d
d n(a,k)|a==[]=0|n<1=0|r>s=1|r<s=2|f/=0=f|t=d(n-length o)(a\\o,k\\u)where(r,o)=b a;(s,u)=b k;f=c o u
i x=head.findIndices(x==)
u(n:k)c#[r,s]|n%z==i r"23456789TJQKA"&&n%4==i s"HDSC"=n|t=u k c
l c=(2&c++snd(splitAt 4c),drop 2c)
main=getLine>>=print.d 5.l.m(u[0..]).words
Ungolfed:
import Control.Exception (assert)
import Data.List (permutations, sort, intersect, findIndices, (\\))
import Data.Function (on)
(%) = mod
aceLowRun = [0,1,2,3,12]
tryTake n xs
| length xs < n = []
| otherwise = take n xs
cond ? xs
| cond = xs
| otherwise = []
eqOn n f cards = allEq (tryTake n $ map f cards) ? tryTake n cards
allEq [] = False
allEq (x:xs) = all (== x) xs
combWithPair pokerHand cards
| any null [picked1, picked2] = []
| otherwise = pokerHand cards
where
picked1 = pokerHand cards
picked2 = pair $ cards \\ picked1
straightFlush = straight . flush
quads = eqOn 4 (% 13)
fullHouse = combWithPair triples
flush = eqOn 5 (% 4)
straight cards = (sort (map (% 13) cards) `elem` runs) ? cards
where
runs = aceLowRun : [[n..n+4] | n <- [0..8]]
triples = eqOn 3 (% 13)
twoPair = combWithPair pair
pair = eqOn 2 (% 13)
single = eqOn 1 id
bestVersionOfHand [] ys = ys
bestVersionOfHand xs [] = xs
bestVersionOfHand xs ys
| compareSameRankedHands xs ys < 2 = xs
| otherwise = ys
rate rating pokerHand cards = (rating, handResult)
where
handResult = foldr1 bestVersionOfHand
(map (pokerHand . take 5) $ permutations cards)
pokerHands = zipWith rate [1..] [
single
, pair
, twoPair
, triples
, straight
, flush
, fullHouse
, quads
, straightFlush
]
bestHand hand = foldr1 (\xs ys -> if null (snd ys) then xs else ys)
(map ($ hand) pokerHands)
highestVals = reverse . arrangeVals . map (% 13)
where
arrangeVals vals = if vals `intersect` aceLowRun == aceLowRun
then [-1..3]
else sort vals
compareSameRankedHands = compareSameRankedHands' `on` highestVals
compareSameRankedHands' [] [] = 0
compareSameRankedHands' (card1:cards1) (card2:cards2)
| card1 > card2 = 1
| card1 < card2 = 2
| otherwise = compareSameRankedHands' cards1 cards2
decideWinner n cards1 cards2
| null cards1 = assert (null cards2) 0
| n < 1 = 0
| rating1 > rating2 = 1
| rating1 < rating2 = 2
| cmpRes /= 0 = cmpRes
| otherwise = decideWinner
(n - assert (length bests1 == length bests2) (length bests1))
(cards1 \\ bests1)
(cards2 \\ bests2)
where
(rating1, bests1) = bestHand cards1
(rating2, bests2) = bestHand cards2
cmpRes = compareSameRankedHands bests1 bests2
indexOf x = head . findIndices (x==)
toNum = toNum' [0..]
toNum' (n:ns) [rank, suit]
| n % 13 == indexOf rank "23456789TJQKA" && n % 4 == indexOf suit "HDSC" = n
| otherwise = toNum' ns [rank, suit]
cluster cards = (take 2 cards ++ snd (splitAt 4 cards), drop 2 cards)
main = getLine >>= print
. uncurry (decideWinner 5)
. cluster
. map toNum
. words
GolfScript 258 241 247/341 217/299 char
Solution for the 10 card problem. Only the last couple of newlines are significant:
10:T):J):Q):K):A;0:a;0:b;0:d;"\r\n"%{' '/5/{.{)\;}/4*-+++!:f;{);~}%{$0:z(%{.z-
!99*+:z}%}5*.{+}*99/:P!{..)\(#4+-!2*\;\.2<~9+-!\;+}and:s;[s f*6P=4P=f s P 6$]\;}
%.~={;;d):d;}{~>{a):a;}{b):b;}if}if}/
'1: 'a'
2: 'b'
D: 'd n
The 9 card problem currently needs about 80 more characters.
10:T):J):Q):K):A;0:a;0:b;0:d;"\r\n"%{' '/);{('Z'%+}2*[0$2>\7<]
{:H;7,{H=:x;H{x=!},:I;6,{I=:x;I{x=!},}/}%{.{)\;}/4*-+++!:f;
{);~}%{$0:z(%{.z-!99*+:z}%}5*.{+}*99/:P!{..)\(#4+-!2*\;\.2<~9+-!\;+}and:s;[
s f*6P=4P=f s P 6$]\;}%{[\].~>{~;}{~\;}if}*}%.~={;;d):d;}{~>{a):a;}{b):b;}if}if}/
'1: 'a'
2: 'b'
D: 'd n
Less golfed version of 10 card problem.
10:T;11:J;12:Q;13:K;14:A; # map for face cards
0:a;0:b;0:d; # other initialization
"\r\n"% # split input on \n
{ # on each line of input
' '/ # divide line into ten cards
5/ # split into five card hands
{. # on each of the two hands
{)\;}% # chop last character of each card
.(5*\;\{+}*= # check sum of elem == 5*1st elem
:f; # this is the flush flag
{);~}%$ # reduce cards to numerical values
0:z;{.z- 20%{}
{;z 20+}if:z}%{-1*}$ # detect pairs
.(:h;; # extract value of highest card
20h>{..)\(#4+-!2*\;\ # detect straight
.2<~9+-!\;+}and:s; # s=2 for regular straight, s=1 for A-5 straight
# result of this mapping - 6 elem array
[ 0$ # #6 - cards in the hand
.{20/}%{+}*:P # #5 - number of pairs
s # #4 - is this a straight?
f # #3 - is this a flush?
4P= # #2b - is this a full house?
h 59> # #2 - is this 4 of a kind?
s f * # #1 - is this a straight flush?
]-1%
\;
}/
\.#.# # put [hand1 hand2 hand1 hand2] on stack
= # check hand1==hand2
{;;d):d;} # if equal, increment d (draw)
{>{a):a;} # if >, increment a (player 1 wins)
{b):b;}if # if <, increment b (player 2 wins)
}if
}/
# output results
'1: 'a'
2: 'b'
D: 'd n
C, 665+379 chars
Here's my answer in 2 parts.
The first is a complete 7 card evaluator, including the "AddCard" macro A. It returns a 32-bit number ranking the hand. The high nibble is the type, bits 13..25 indicate the high card(s) and bits 0..12 indicate the kicker(s). When comparing the results, the better hand will always have the larger value.
#define U unsigned
#define c(a)X=a;i=C=0;while(X){C|=(X&1)<<i++;X/=4;}
#define A(h,c)h[c&7]+=c,h[3]|=c
U C,i,X;
U E(U h[]){
U a=h[0]+h[1]+h[2]+h[4]-(h[3]&-16),t,v,k,e=a&0x55555540,o=a&0xAAAAAA80;
if(v=e&o/2){t=7;k=h[3]^v;i=0;while(k/=4)i++;k=1<<2*i;}
else if(v=o&o-1){t=6;v/=2;k=o/2^v;}
else if(e>1&o>1){t=6;v=o/2;k=(i=e&e-1)?i:e;}
else{a=h[3];
if(t=h[i=1]-(a&1)&4||h[i=2]-(a&2)&8||h[i=4]-(a&4)&16||h[i=0]-(a&8)&32)a=h[i];
a&=-64;v=a|a>>26&16;t*=5;
if(v=v&v<<2&v<<4&v<<6&v<<8){t+=4;a=v&=~(v/2);}
else if(t)for(i=(h[i]&63)/(i?i:8),v=a;i-->5;)a&=a-1;
else if(v=o/2)t=3;
else if (e){o=e&e-1;v=(i=o&o-1)?o:e;t=1+(o>0);}
k=a^v;k&=k-1;k&=k-(i==0);}
c(v);v=C/8;c(k);
return t<<28|v<<13|C/8;}
The second is the input processor. It parses the project Euler file as 2+2+5 cards (ignoring the 10th card). It uses the Parse macro, P to create 32-bit values representing each card. The representation is 0A0K0Q0J0T090807060504030200shdc. A hand is stored as an array of 5 ints.
char*gets(char*);char*strchr(char*,char);
#define P(c)X=strchr(R,*c++)-R;C=1<<strchr(S,*c++)-S|64<<X*2;c++;
#define L(n)for(i=0;i<n;i++)
U g[5],h[5];
char*c,b[32];
char*S="CDHS";
char*R="23456789TJQKA";
int d,r[3]={0};
main(q){while(c=gets(b)){
L(2){P(c)A(g,C);}
L(2){P(c)A(h,C);}
L(5){P(c)A(g,C);A(h,C);}
d=E(g)-E(h);
r[d>0?0:d<0?1:2]++;
L(7)g[i]=h[i]=0;
}L(3)printf("%c:%d\n","12D"[i],r[i]);}
I'm sure there are a few more characters to be trimmed off. I'll add an explanation soon.
The evaluator runs #17.6 Million hands/second on my 3Ghz Core2 Duo. That's only 3.5x slower than the PokerSource evaluator, which uses at least 56K of lookup tables.
PHP, 799 chars
Line breaks are not significant. This takes input from the linked url, which is different from the example input (doesn't deal with community cards). Processing is similar to mobrule's perl answer, with a different scoring method.
<?php
function s($i){$o=array_map('intval',$i);$f=(count(array_unique(str_replace($o,'',$i)))==1);
sort($o);$v=array_count_values($o);arsort($v);$u=array_keys($v);$h=max($u);$m=$u[0];$c=reset($v);
$p=count($v);$e=$c==1&&$o[4]==14&&$o[3]==5;$r=$o==range($o[0],$o[0]+4)||$e;$q=$e?5:$h;
$s=($f&&$r&&($h==12)?2<<11:($f&&$r?(2<<10)+$q:0))+($c==4?(2<<9)+$m:0)+($c==3&&$p==2?(2<<8)+$m:0)+($f?(2<<7)+$h:0)+
($r?(2<<6)+$q:0)+($c==3?(2<<5)+$m:0)+($c==2&&$p==3?(2<<4)+$m:0)+($p==4?(2<<3)+$m:0);$s+=!$s?$h:0;return array($s,$u);}
foreach(file($argv[1]) as $d){
list($y,$z)=array_chunk(explode(' ',trim(strtr($d,array('T'=>10,'J'=>11,'Q'=>12,'K'=>13,'A'=>14)))),5);
$y=s($y);$z=s($z);$w=$y[0]-$z[0];$x=1;while(!$w&&$x<5){$w=$y[1][$x]-$z[1][$x++];}if(!$w)#$t++;elseif($w<0)#$l++;else #$k++;}
#print "1: $k\n2: $l\nD: $t";

Code Golf: Decision Tree

Locked. This question and its answers are locked because the question is off-topic but has historical significance. It is not currently accepting new answers or interactions.
In Google Code Jam 2009, Round 1B, there is a problem called Decision Tree that lent itself to rather creative solutions.
Post your shortest solution; I'll update the Accepted Answer to the current shortest entry on a semi-frequent basis, assuming you didn't just create a new language just to solve this problem. :-P
Current rankings:
107 Perl
121 PostScript (binary)
132 Ruby
154 Arc
160 PostScript (ASCII85)
170 PostScript
192 Python
196 JavaScript
199 Common Lisp
212 LilyPond
273 Scheme
280 R
281 sed w/ bc
312 Haskell
314 PHP
339 m4 w/ bc
346 C
381 Fortran
462 Java
718 OCaml
759 F#
1554 sed
C++ not qualified for now
sed in 1554 chars (pure) / 281 (with bc)
Yes, seriously.
Usage: sed -r -f thisfile.sed < input.in > output.out
(works on GNU sed)
1d
/ /!{x
s/^$/Case #Y:/
:i
s/9Y/Y0/
ti
s/#Y/#0Y/
s/:/:0123456789/
s/(.)Y(.*):[0-9]*\1(.).*/\3\2Y:/
x
G
s/.*\n|Y//gp
z
:p
N
/[()]/s/ |\n//g
y/()/JK/
tp
H
d}
G
s/\n[^J]*/ %/
s/[^JK]*$//
:c
s/J1?([.-9]+)(.*)K/\2#\1/
/%#/by
:b
/J/s/T//
s/J([^JK]*)K/TC\1B/
tb
/ (.+) .*%\1C/{s/%[^C]*/%/
s/T.*B//
by}
s/%.*T/%/
:y
y/CB/JK/
tc
s/.\.0*\b//g
:r
/#.*#/{s/\w*#\w*$/C&B/
s/C(\w)(.*B)/\1C\2~/
s/"[^"]*/&0/g
:t
s/(\w)(C.*)(\w)B(.*~)/\1\2B\3\4\1\3/
T
s/~(10|2[01]|3[0-2]|4[0-3]|5[0-4]|6[0-5]|7[0-6]|8[0-7]|9.)/&Q/
s/(.)(.)Q/\2\1/
s/~0\w/`00/
s/~1\B/`0/
s/~22/`04/
s/~23/`06/
s/~24/`08/
s/~33/`09/
s/~25/`10/
s/~26|~34/`12/
s/~27/`14/
s/~28|~44/`16/
s/~29|~36/`18/
s/~35/`15/
s/~45/`20/
s/~37/`21/
s/~38|~46/`24/
s/~55/`25/
s/~39/`27/
s/~47/`28/
s/~56/`30/
s/~48/`32/
s/~57/`35/
s/~49|~66/`36/
s/~58/`40/
s/~67/`42/
s/~59/`45/
s/~68/`48/
s/~77/`49/
s/~69/`54/
s/~78/`56/
s/~79/`63/
s/~88/`64/
s/~89/`72/
s/~99/`81/
s/`(.)(.)/~\1'\2/
bt
:
s/(~.)'/\1/
s/..'/K&/
/K/bk
:v
s/=(,?.)'/\1/
s/,/1'/
t
s/B(.*)~/\1B"/
tr
s/"(\w*)0/A\1/g
/A.*A/{s/A[^A]*$/J&K/
:k
s/([^A])(J.*)([^A])K/\2K\1\3/
s/K(10|2[01]|3[0-2]|4[0-3]|5[0-4]|6[0-5]|7[0-6]|8[^9]|9.)/&Q/
s/(.)(.)Q/\2\1/
s/K0/=/
s/K11/=2/
s/K12/=3/
s/K13|K22/=4/
s/K14|K23/=5/
s/K15|K24|K33/=6/
s/K16|K25|K34/=7/
s/K(17|26|35|44)/=8/
s/K(18|27|36|45)/=9/
s/K(19|28|37|46|55)/W0/
s/K(29|38|47|56)/W1/
s/K(39|48|57|66)/W2/
s/K49|K58|K67/W3/
s/K59|K68|K77/W4/
s/K69|K78/W5/
s/K79|K88/W6/
s/K89/W7/
s/K99/W8/
s/W/=,/
/'/bv
s/\b=/K:/
tk
s/[:JK]A?//g
s/,/,0123456789GF/
s/(.),.*\1(.).*F/\2/
s/G/,0/
tk}
/A.*A/bv}
s/\w*C.*A//
tr
s/.*#/./
This solution omits the leading zero in front of the decimal point, and does not handle cases where the answer is 1.00. Luckily, the GCJ judge accepts the lack of a zero, and does not have any cases where the answer is 1.00.
To include the leading zero, change the last line to s/.*#/0./; and to handle a 1.00 case, append the line s/^$/1/.
Here's a solution that outsources the multiplication to bc:
1d
/ /!{x
s/\n.*//
s/.*/echo 0&+1|bc/e
x
g
s/.*/Case #&:/p
:p
N
/[()]/s/ |\n//g
y/()/JK/
tp
H
d}
G
s/\n[^J]*/ %/
s/[^JK]*$//
:c
s/J([.-9]+)(.*)K/\2*\1/
/%\*/s/.*%.(.*)/echo \1|bc -l/e
:b
/J/s/T//
s/J([^JK]*)K/TC\1B/
tb
/ (.+) .*%\1C/{s/%[^C]*/%/
s/T.*B//
b}
s/%.*T/%/
:
y/CB/JK/
tc
Perl in 107 characters
say("Case #$_:"),
$_=eval"''".'.<>'x<>,
s:[a-z]+:*(/ $&\\s/?:g,s/\)\s*\(/):/g,
eval"\$_=<>;say$_;"x<>for 1..<>
Newlines for legibility; none of them is necessary or counted in.
It uses features found only in the latest versions of Perl, so run with perl -M5.010 or later.
I used to be a Perl noob too, so this works almost the same as the ruby one. Original version 126 chars, optimizations by peutri.
Backlinks:
Word Aligned - Power Programming
LilyPond: 212 characters
Craziness! Utter ridiculousness!! LilyPond, with its built-in Scheme interpreter, manages to outdo Scheme by more than FIFTY BYTES! Holy acrobatic flying mooses in tights!!
x=#lambda
w=#read
#(letrec((v(x(a)(map a(iota(w)1))))(c(x(f q)(*(car q)(if(any list? q)(c
f((if(memq(cadr q)f)caddr cadddr)q))1)))))(v(x(i)(w)(set! #(w))(format
#t"Case #~a:
~{~y~}"i(v(x i(w)(c(v(x i(w)))#)))))))
Usage: lilypond thisfile.ly <input.in >output.out 2>/dev/null
Credit goes to cky for writing the Scheme solution this was based on, though this version is now substantially different. Seriously, though, the Scheme could be golfed a bit further...
PostScript: 170 (regular) / 160 (ASCII85) / 121 (binary)
My shortest (regular) PostScript solution so far, provided that you rename the input file to "r" (170 characters, including newlines); uses a GhostScript-specific procedure (=only):
1[/:{repeat}/!{exch token{\ exch known{/<>}if]pop]]3 index mul
!}if}(]){token pop}/?(r)(r)file([){?]}>>begin
1[{(Case #)2{=only}:(:)=[/|[def[{[/\<<[{[/}:>>def |]! =}:}for
Usage: cp input.in r; gs -q -dNOPROMPT -dNODISPLAY -dBATCH thisfile.ps > output.out
Here's a binary version of this in 121 bytes (backslashes and unprintable characters escaped):
1[/!{\x92>\x92\xab{\\\x92>\x92`\x92p{]\x92u}if]]3\x92X\x92l!}if}(]){\x92\xab\x92u}/r(r)\x928\x92A([){r]}>>\x92\r1[{(Case #)\x92v=only[/:\x928[\x923=[{[/\\<<[{[/}\x92\x83>>\x923:]! =}\x92\x83}\x92H
If characters outside the ASCII printable range are disallowed, PS has built-in ASCII85 encoding of binary sources. We therefore have the following 160-byte solution in all ASCII printable characters:
1[([){r]}/r(r)<~OuSUj0-P\*5*Dsn>`q:6#$5JU?'9>YBkCXV1Qkk'Ca"4#Apl(5.=75YP')1:5*?#0>C.bc#<6!&,:Se!4`>4SH!;p_OuQ[/1Herh>;'5D4Bm/:07B"95!G,c3aEmO4aiKGI?I,~>cvx exec
Ruby in 132
Improved by leonid. Newlines are essential.
def j
'1
'..gets
end
j.map{|c|s=j.map{gets}*''
puts"Case #%d:"%c,j.map{gets;eval s.gsub(/[a-z]+/,'*(/ \&\b/?').gsub /\)\s*\(/,'):'}}
Ruby in 136
def j;1..gets.to_i;end;j.map{|c|m=j.map{gets}*"";puts"Case ##{c}:";j.map{gets;p eval m.gsub(/[a-z]+/,'*(/ \0\s/?').gsub /\)\s*\(/,'):'}}
I just learned about *"" being equivalent to .join"". Also realised that map could be used in a few places
Ruby in 150
1.upto(gets.to_i){|c|m=eval("gets+"*gets.to_i+"''");puts"Case ##{c}:";1.upto(gets.to_i){gets;p eval m.gsub(/[a-z]+/,'*(/ \0\s/?').gsub /\)\s*\(/,'):'}}
I am just a noob to ruby, so there is probably still a lot of room for improvement
Python in 192
import re;S=re.sub;R=raw_input;I=input;c=0;exec r"c+=1;L=S('\) *\(',')or ',S('([a-z]+)','*(\' \\1 \'in a and',eval(('+R()'*I('Case #%s:\n'%c))[1:])));exec'a=R()+\' \';print eval(L);'*I();"*I()
Common Lisp, 199 bytes
Wrapped every 80 characters:
(defun r()(read))(dotimes(i(r))(format t"~&Case #~D:"(1+ i))(r)(set'z(r))(dotime
s(a(r))(r)(print(do((g(mapcar'read(make-list(r))))(p 1(*(pop c)p))(c z(if(find(p
op c)g)(car c)(cadr c))))((not c)p)))))
Spaced and indented:
(defun r () (read))
(dotimes (i (r))
(format t "~&Case #~D:" (1+ i))
(r)
(set 'z (r))
(dotimes (a (r))
(r)
(print
(do ((g (mapcar 'read (make-list (r))))
(p 1 (* (pop c) p))
(c z (if (find (pop c) g)
(car c)
(cadr c))))
((not c) p)))))
C - 346 bytes
Compile with gcc -w
#define N{int n=atoi(gets(A));for(;n--;)
T[999];F[99];char*t,*f,*a,A[99];float p(){float
d,m=1;for(;*t++^40;);sscanf(t,"%f %[^ (]",&d,A);if(*A^41){for(f=F;m**f;){for(;*f&&*f++^32;);for(a=A;*a&&*f==*a;f++,a++);m=*a||*f&64;}d*=!m*p()+m*p();}return
d;}main(I)N{printf("Case #%d:\n",I++);t=T;N
for(gets(t);*++t;);}N gets(F),t=T,printf("%f\n",p());}}}
Arc, 143 154 characters
Very similar to the CL one, but Arc sure has terse identifiers. Wrapped every 40 chars:
(for i 1((= r read))(prn"Case #"i":")(r)
(= z(r))(repeat(r)(r)(loop(= g(n-of(r)(r
))c z p 1)c(= p(*(pop c)p)c(if(pos(pop c
)g)c.0 cadr.c)))prn.p))
Indented:
(for i 1 ((= r read))
(prn "Case #" i ":")
(r)
(= z (r))
(repeat (r)
(r)
(loop (= g (n-of (r) (r))
c z
p 1)
c
(= p (* (pop c) p)
c (if (pos (pop c) g)
(c 0)
(cadr c))))
(prn p)))
Backlink: Word Aligned - Power Programming
JavaScript in 196 bytes
r='replace'
q=readline
for(n=0,t=q();t-n++;){for(print('Case #'+n+':'),d='',x=q();x--;d+=q());for(x=q();x--;)print(eval(d[r](/([a-z]+)/g,'*({'+q()[r](/ /g,':1,z')+':1}.z$1?')[r](/\) *\(/g,'):')))}
Usage: $ smjs thisfile.js <input.in
With contributions by Hyperlisk.
PHP in 314
<?php function q(){return trim(fgets(STDIN));}for($n=q($x=0);$x++<$n;){for($s=q($t='');$s--;$t.=q());echo"Case #$x:\n";for($z=q();$z--;){$l=explode(' ',q());$l[0]=0;printf("%f\n",eval('return'.preg_replace(array('/\(/','/(\w+),/','/(\d\)*),\((\d)/','/^./'),array(',(','*(in_array("$1",$l,1)?','$1:$2'),$t).';'));}}
FORTRAN - 381
Save as a.F95
Compile with f95 a.F95
#define _ ENDDO
#define A READ(t(k:l-1),*),a
#define Q j=1,n;READ"(A)",s
#define R READ*,n;DO
#define S k+SCAN(t(k:),'()')
CHARACTER(999)s,t,u;R i=1,n;t="";PRINT"('Case #'i0':')",i
R Q;t=TRIM(t)//s;_;R Q;d=1;k=1;DO;k=S;l=S-1
IF(t(l:l)>"(")EXIT;A,u;d=d*a;k=l;m=0
IF(INDEX(s," "//TRIM(u)//" ")>0)CYCLE;DO;IF(')'>t(k:k))m=m+2;m=m-1;k=k+1
IF(1>m)EXIT;k=S-1;_;_;A;d=d*a;PRINT*,d;_;_;END
By using the default format, each of the results starts with 2 spaces, but the google judge permits it. Thanks google judge!
EXPANDED VERSION
CHARACTER(999)s,t,u
READ*,n
DO i=1,n
t=""
PRINT"('Case #'I0':')",i
READ*,n
DO j=1,n
READ"(A)",s
t=TRIM(t)//s
ENDDO
READ*,n
DO j=1,n
READ"(A)",s
d=1
k=1
DO
k=k+SCAN(t(k:),'()')
l=k+SCAN(t(k:),'()')-1
IF(t(l:l)>"(")THEN
READ(t(k:l-1),*),a
d=d*a
PRINT*,d
EXIT
ELSE
READ(t(k:l-1),*),a,u
d=d*a
k=l
m=0
IF(INDEX(s," "//TRIM(u)//" ")>0)CYCLE
DO
IF(')'>t(k:k))m=m+2
m=m-1
k=k+1
IF(1>m)EXIT
k=k+SCAN(t(k:),'()')-1
ENDDO
ENDIF
ENDDO
ENDDO
ENDDO
END
Haskell, 312 characters
Here's another aproach to Haskell. I left the dirty work to the Prelude's lex. The wrapping around it is Text.ParserCombinators.ReadP. Importing it cost 36 characters on its own—ugh!
The parser is a Features -> SExp -> Cuteness function, which spares me most of the type declarations in quibble's/yairchu's solution.
import Text.ParserCombinators.ReadP
main=f(\t->do putStrLn$"Case #"++show t++":";s<-r g;r$print.fst.head.($id=<<s).readP_to_S.d.tail.words=<<g)
d x=do"("<-e;w<-e;c<-do{f<-e;y<-d x;n<-d x;u$if elem f x then y else n}<++u 1.0;e;u$c*read w
f x=do n<-g;mapM x[1..read n]
e=readS_to_P lex
r=f.const
g=getLine
u=return
It used to use Control.Monad's join, forM_ and replicateM, but it turns out it takes less space to redefine them approximately than to import.
I also abandoned the Prelude's readParen in favor of just calling lex before and after. In the current version, there is no need to verify the closing parenthesis: on a valid input it will always be there. On the other hand, it is vital to check the opening one: since the number is only converted after the whole subexpression has been read, a lot of backtracking would be needed to align to the correct parse.
On a theoretical machine with infinite memory and time to spare, the "("<- part might be dropped (4 characters' gain, 308 in total). Unless the call to read just aborts. On mine, the stack just overflows pretty fast.
Java in 467 bytes
This uses the javascript interpreter contained in java 6.
import java.util.*;class D{static{Scanner c=new
Scanner(System.in);int n=c.nextInt(),i=0,l;while(i++<n){l=c.nextInt();String
s="(";while(l-->=0)s+=c.nextLine();System.out.println("Case #"+i+":");l=c.nextInt();while(l-->0)try{c.next();System.out.println(new
javax.script.ScriptEngineManager().getEngineByName("js").eval(s.replace(")","))").replaceAll("\\) *\\(",":(").replaceAll("[a-z]+","*(/ $0 /.test('"+c.nextLine()+" ')?")));}catch(Exception
x){}}System.exit(0);}}
Thanks Varan, Chris and pfn (indirectly) for helping me shorten it.
Please see my other (even shorter!) java answer.
m4 with echo and bc, 339 bytes
This solution is a complete and utter hack, and it gives me a headache. It contains, among other things, escaped double quotes, unescaped double quotes, unescapable backquote and single quote pairs (including a nested pair seven quotes deep), unquoted regular expressions, outsourcing decimal multiplication to bc, and the use of craZy caSE to circumvent macro expansion. But it had to be done, I guess. :p
This adds an "ultimate macroizing" solution to the previous kinds of solutions (iterated loops, recursion w/ lambda mapping, labels and branches, regexp and eval, etc.)
I think a good term for this is "macroni code" :D
(wrapped every 60 characters, for clarity)
define(T,`translit($#)')define(Q,`patsubst($#)')define(I,0)Q
(T(T(T(Q(Q(Q(Q(Q(Q(T(include(A),(),<>),>\s*>,>>),>\s*<,>;),\
([a-z]+\)\s*<,`*ifElsE<rEgExp<P;``````` \1 ''''''';0>;0;<'),
^<,`defiNe<````I';iNcr<I>>\\"Case `#'I:\\"defiNe<`A'''';'),^
[0-9]*),.+ [0-9]+.*,`dEfiNE<```P';`\& '''>A'),<>;N,`(),n'),E
,e),()),.*,`syscmd(`echo "\&"|bc -l')')
Usage: $ cp input.in A; m4 thisfile.m4 > output.out
I'm an m4 n00b, though, having learned it only an hour before writing this. So there's probably room for improvement.
C++ in 698 bytes
Compile with 'g++ -o test source.cpp -include iostream -include vector -include sstream'
#define R(x,f,t) for(int x=f;x<t;x++){
#define S(x) x.size()
#define H string
#define U while
#define I if
#define D cin>>
#define X t.substr(p,S(t))
using namespace std;
int main(){int h,l,n,a,p,Y,W;D h;for(int q=1;q<=h;q++){D l;H s;char c;D c;R(i,0,l)H L;getline(cin,L);R(j,0,S(L))I (L[j]==41||L[j]==40)s+=32;s+=L[j];I(L[j]==40)s+=32;}}D a;printf("Case #%d:\n",q);R(i,0,a)H N;D N;D n;vector<H>f;R(j,0,n)D N;f.push_back(N);}H t=s;float P=1;p=0;U(p<S(t)-1){p=0;U(t[p]!=48&&t[p]!=49)p++;t=X;stringstream T(t);float V;T>>V;H F;T>>F;P*=V;I(F[0]==41)break;Y=0;R(j,0,S(f))if(F==f[j])Y=1;}p=t.find(40)+1;t=X;p=0;I(Y==0){W=1;U (W>0){I(t[p]==40)W++;I(t[p]==41)W--;p++;}t=X;p=0;}}cout<<P<<endl;}}return 0;}
EDIT: I'm sorry; I thought it was ok for the includes (eg, C works even w/o including basic libraries), while I'm sure it would be if I decleared the defines this way.
I'm not home now, and I won't be for some time: I won't be able to modify it. Just ignore my submission.
OCaml in 718 bytes
I'm an OCaml n00b, so this is probably much longer than it needs to be.
Usage: ocaml thisfile.ml <input.in >output.out
#load"str.cma";;open List;;open String;;open Str;;let x=length and
y=Printf.printf and e=global_replace and h=float_of_string and b=regexp and
k=index and r=read_line and a=read_int and w s m c=sub s(c+1)(m-c-1);;for i=1to
a()do y"Case #%d:\n"i;let t=let n=a()in let rec g d j=if j>n then d else
g(d^(r()))(j+1)in e(b" ")""(e(b"\\b")"^"(g""1))and n=a()in let rec z j=if j>n
then()else let q=tl(split(b" ")(r()))in let rec g l j s p=let o=k s '('and c=k
s ')'in if j then let f=w s c o in if contains f '('then let m=k s '^'in let
c=index_from s(m+1)'^'in g 0(mem(w s c m)q)(w s(x s)c)(h(w s m o)*.p)else h f*.p
else if o<c then g(l+1)j(w s(x s)o)p else g(l-1)(l=1)(w s(x s)c)p in y"%f\n"(g
0(0=0)t 1.);z(j+1)in z 1done
Scheme (Guile 1.8)
Here's my version at 278 bytes (with improvements from KirarinSnow to bring it down to 273), after stripping off all the newlines (except ones in string literals, of course). It only works on Guile 1.8 (since in standard Scheme, define is a syntax, not an object, but Guile represents it as an object anyway).
(define ! define)
(!(c f p w . r)(if(null? r)(* p w)(apply c f(* p w)((if(memq(car r)f)cadr caddr)r))))
(!(d . l)(map display l))
(!(r . x)(read))
(! n(r))
(do((i 1(1+ i)))((> i n))(r)(let((t(r)))(d"Case #"i":
")(do((a(r)(1- a)))((= a 0))(r)(d(apply c(map r(iota(r)))1 t)"
"))))
Pure java in 440 bytes
A shorter java solution that doesn't use any eval trick. Can be reduced to 425 by removing System.exit(0) if stderr output is ignored.
import java.util.*;enum A{_;Scanner c,d;float p(String a){return
d.nextFloat()*(d.hasNext("\\D+")?a.contains(' '+d.next()+' ')?p(a)+0*p(a):0*p(a)+p(a):1);}{c=new
Scanner(System.in);for(int n=c.nextInt(),i=0,l;i++<n;){String
s="";for(l=c.nextInt();l-->=0;)s+=c.nextLine();System.out.println("Case #"+i+":");for(l=c.nextInt();l-->0;){c.next();d=new
Scanner(s.replaceAll("[()]"," "));System.out.println(p(c.nextLine()+' '));}}System.exit(0);}}
Haskell, 514 bytes (I suck?).
Based on quibble's solution:
import Control.Monad
import Text.ParserCombinators.Parsec
data F=N|F String(Float,F)(Float,F)
r=return
f=many1 letter>>= \i->w>>d>>= \t->d>>=r.F i t
d=char '('>>w>>many1(oneOf".0123456789")>>= \g->w>>(f<|>r N)>>= \p->char ')'>>w>>r(read g,p)
w=many$oneOf" \n"
g=getLine
l=readLn
m=replicateM
main=l>>= \n->forM_[1..n]$ \t->putStrLn("Case #"++show t++":")>>l>>=(`m`g)>>=(\(Right q)->l>>=(`m`p q)).parse d"".join
z(p,f)=(p*).y f
y N _=1
y(F n t f)x=z(if n`elem`x then t else f)x
p q=fmap(drop 2.words)g>>=print.z q
C in 489 bytes
Code wrapped at 80 chars, there are actually just 3 lines.
Save in a.c and compile with: gcc -w a.c -o a
#define S int I,N;scanf("%d\n",&N);for(I=-1;++I<N;)
#define M 1000
char B[M],Z[M],Q[M]={' '},*F[M],*V;float W[M],H;int J,C,L[M],R[M];t(){V=strtok(0
," \n()");}p(){int U=C++;F[U]=0;if(!V)t();sscanf(V,"%f",W+U);t();if(V&&*V>='a')s
trcpy(Q+1,V),V=0,F[U]=strdup(strcat(Q," ")),L[U]=p(),R[U]=p();return U;}main(){S
{printf("Case #%d:\n",I+1);*B=0;{S strcat(B,gets(Z));}V=strtok(B," \n(");C=0,p()
;{S{strcat(gets(B)," ");for(J=0,H=W[0];F[J];J=strstr(B,F[J])?L[J]:R[J],H*=W[J]);
printf("%f\n",H);};}}}
F#: 759 significant chars (Wow, I'm bad at this ;) )
Minimized version
open System.Text.RegularExpressions
type t=T of float*(string*t*t)option
let rec e=function x,T(w,Some(s,a,b))->e(x,if Set.contains s x then a else b)*w|x,T(w,_)->w
let rec h x=Regex.Matches(x, #"\(|\)|\d\.\d+|\S+")|>Seq.cast<Match>|>Seq.map (fun x -> x.Value)|> Seq.toList
let rec p=function ")"::y->p y|"("::w::x::y->match x with ")"->T(float w,None),y|n->let a,f=p y in let b,g=p f in T(float w,Some(n,a,b)),g
let solve input =
Regex.Matches(input,#"(\(((?<s>\()|[^()]|(?<-s>\)))*\)(?(s)(?!)))\s+\d+\s+((\S+\s\d(.+)?\s*)+)")
|>Seq.cast<Match>
|>Seq.map(fun m->fst(p(h(m.Groups.[1].Value))), [for a in m.Groups.[3].Value.Trim().Split([|'\n'|])->set(a.Split([|' '|]))])
|>Seq.iteri(fun i (r,c)->printfn"Case #%i"(i+1);c|>Seq.iter(fun x->printfn"%.7F"(e(x, r))))
Readable version
open System.Text.RegularExpressions
type decisionTree = T of float * (string * decisionTree * decisionTree) option
let rec eval = function
| x, T(w, Some(s, a, b)) -> eval(x, if Set.contains s x then a else b) * w
| x, T(w, _) -> w
// creates a token stream
let rec tokenize tree =
Regex.Matches(tree, #"\(|\)|\d\.\d+|\S+")
|> Seq.cast<Match>
|> Seq.map (fun x -> x.Value)
|> Seq.toList
// converts token stream into a decisionTree
let rec parse = function
| ")"::xs -> parse xs
| "("::weight::x::xs ->
match x with
| ")" -> T(float weight, None), xs
| name ->
let t1, xs' = parse xs
let t2, xs'' = parse xs'
T(float weight, Some(name, t1, t2)), xs''
// uses regex to transform input file into a Seq<decisionTree, list<set<string>>, which each item in our
// list will be tested against the decisionTree
let solve input =
Regex.Matches(input, #"(\(((?<s>\()|[^()]|(?<-s>\)))*\)(?(s)(?!)))\s+\d+\s+((\S+\s\d(.+)?\s*)+)")
|> Seq.cast<Match>
|> Seq.map (fun m -> fst(parse(tokenize(m.Groups.[1].Value))), [for a in m.Groups.[3].Value.Trim().Split([|'\n'|]) -> set(a.Split([|' '|])) ])
|> Seq.iteri (fun i (tree, testCases) ->
printfn "Case #%i" (i+1)
testCases |> Seq.iter (fun testCase -> printfn "%.7F" (eval (testCase, tree)))
)
R in 280 bytes
Note: On the standard distribution of R (as of v. 2.9.2), this program does not pass the large input and fails on just Case 28 (which is nested to 99 levels), generating a "contextstack overflow". To fix this, modify the line in src/main/gram.c that reads
#define CONTEXTSTACK_SIZE 50
and replace the 50 with something like 500. Then recompile. Et voilà!
n=0
g=gsub
eval(parse(text=g('[^
]* [0-9]+( [^
]*|
)','f=c(\\1)
cat(eval(d),"
")
',g('
\\(','
cat("Case #",n<-n+1,":
",sep="")
d=expression(',g('" "','","',g(')\\s*\\(',',',g(' *("[a-z]+")\\s*\\(','*ifelse(\\1%in%f,',g('([a-z]+)','"\\1"',paste(readLines('A'),collapse='
')))))))))
Usage (requires renaming input): cp input.in A; R -q --slave -f thisfile.R >output.out

Has anyone seen a programming puzzle similar to this?

"Suppose you want to build a solid panel out of rows of 4×1 and 6×1 Lego blocks. For structural strength, the spaces between the blocks must never line up in adjacent rows. As an example, the 18×3 panel shown below is not acceptable, because the spaces between the blocks in the top two rows line up.
There are 2 ways to build a 10×1 panel, 2 ways to build a 10×2 panel, 8 ways to build an 18×3 panel, and 7958 ways to build a 36×5 panel.
How many different ways are there to build a 64×10 panel? The answer will fit in a 64-bit signed integer. Write a program to calculate the answer. Your program should run very quickly – certainly, it should not take longer than one minute, even on an older machine. Let us know the value your program computes, how long it took your program to calculate that value, and on what kind of machine you ran it. Include the program’s source code as an attachment.
"
I was recently given a programming puzzle and have been racking my brains trying to solve it. I wrote some code using c++ and I know the number is huge...my program ran for a few hours before I decided just to stop it because the requirement was 1 minute of run time even on a slow computer. Has anyone seen a puzzle similar to this? It has been a few weeks and I can't hand this in anymore, but this has really been bugging me that I couldn't solve it correctly. Any suggestions on algorithms to use? Or maybe possible ways to solve it that are "outside the box". What i resorted to was making a program that built each possible "layer" of 4x1 and 6x1 blocks to make a 64x1 layer. That turned out to be about 3300 different layers. Then I had my program run through and stack them into all possible 10 layer high walls that have no cracks that line up...as you can see this solution would take a long, long, long time. So obviously brute force does not seem to be effective in solving this within the time constraint. Any suggestions/insight would be greatly appreciated.
The main insight is this: when determining what's in row 3, you don't care about what's in row 1, just what's in row 2.
So let's call how to build a 64x1 layer a "row scenario". You say that there are about 3300 row scenarios. That's not so bad.
Let's compute a function:
f(s, r) = the number of ways to put row scenario number "s" into row "r", and legally fill all the rows above "r".
(I'm counting with row "1" at the top, and row "10" at the bottom)
STOP READING NOW IF YOU WANT TO AVOID SPOILERS.
Now clearly (numbering our rows from 1 to 10):
f(s, 1) = 1
for all values of "s".
Also, and this is where the insight comes in, (Using Mathematica-ish notation)
f(s, r) = Sum[ f(i, r-1) * fits(s, i) , {i, 1, 3328} ]
where "fits" is a function that takes two scenario numbers and returns "1" if you can legally stack those two rows on top of each other and "0" if you can't. This uses the insight because the number of legal ways to place scenario depends only on the number of ways to place scenarios above it that are compatible according to "fits".
Now, fits can be precomputed and stored in a 3328 by 3328 array of bytes. That's only about 10 Meg of memory. (Less if you get fancy and store it as a bit array)
The answer then is obviously just
Sum[ f(i, 10) , {i, 1, 3328} ]
Here is my answer. It's Haskell, among other things, you get bignums for free.
EDIT: It now actually solves the problem in a reasonable amount of time.
MORE EDITS: With a sparse matrix it takes a half a second on my computer.
You compute each possible way to tile a row. Let's say there are N ways to tile a row. Make an NxN matrix. Element i,j is 1 if row i can appear next to row j, 0 otherwise. Start with a vector containing N 1s. Multiply the matrix by the vector a number of times equal to the height of the wall minus 1, then sum the resulting vector.
module Main where
import Data.Array.Unboxed
import Data.List
import System.Environment
import Text.Printf
import qualified Data.Foldable as F
import Data.Word
import Data.Bits
-- This records the index of the holes in a bit field
type Row = Word64
-- This generates the possible rows for given block sizes and row length
genRows :: [Int] -> Int -> [Row]
genRows xs n = map (permToRow 0 1) $ concatMap comboPerms $ combos xs n
where
combos [] 0 = return []
combos [] _ = [] -- failure
combos (x:xs) n =
do c <- [0..(n `div` x)]
rest <- combos xs (n - x*c)
return (if c > 0 then (x, c):rest else rest)
comboPerms [] = return []
comboPerms bs =
do (b, brest) <- choose bs
rest <- comboPerms brest
return (b:rest)
choose bs = map (\(x, _) -> (x, remove x bs)) bs
remove x (bc#(y, c):bs) =
if x == y
then if c > 1
then (x, c - 1):bs
else bs
else bc:(remove x bs)
remove _ [] = error "no item to remove"
permToRow a _ [] = a
permToRow a _ [_] = a
permToRow a n (c:cs) =
permToRow (a .|. m) m cs where m = n `shiftL` c
-- Test if two rows of blocks are compatible
-- i.e. they do not have a hole in common
rowCompat :: Row -> Row -> Bool
rowCompat x y = x .&. y == 0
-- It's a sparse matrix with boolean entries
type Matrix = Array Int [Int]
type Vector = UArray Int Word64
-- Creates a matrix of row compatibilities
compatMatrix :: [Row] -> Matrix
compatMatrix rows = listArray (1, n) $ map elts [1..n] where
elts :: Int -> [Int]
elts i = [j | j <- [1..n], rowCompat (arows ! i) (arows ! j)]
arows = listArray (1, n) rows :: UArray Int Row
n = length rows
-- Multiply matrix by vector, O(N^2)
mulMatVec :: Matrix -> Vector -> Vector
mulMatVec m v = array (bounds v)
[(i, sum [v ! j | j <- m ! i]) | i <- [1..n]]
where n = snd $ bounds v
initVec :: Int -> Vector
initVec n = array (1, n) $ zip [1..n] (repeat 1)
main = do
args <- getArgs
if length args < 3
then putStrLn "usage: blocks WIDTH HEIGHT [BLOCKSIZE...]"
else do
let (width:height:sizes) = map read args :: [Int]
printf "Width: %i\nHeight %i\nBlock lengths: %s\n" width height
$ intercalate ", " $ map show sizes
let rows = genRows sizes width
let rowc = length rows
printf "Row tilings: %i\n" rowc
if null rows
then return ()
else do
let m = compatMatrix rows
printf "Matrix density: %i/%i\n"
(sum (map length (elems m))) (rowc^2)
printf "Wall tilings: %i\n" $ sum $ elems
$ iterate (mulMatVec m) (initVec (length rows))
!! (height - 1)
And the results...
$ time ./a.out 64 10 4 6
Width: 64
Height 10
Block lengths: 4, 6
Row tilings: 3329
Matrix density: 37120/11082241
Wall tilings: 806844323190414
real 0m0.451s
user 0m0.423s
sys 0m0.012s
Okay, 500 ms, I can live with that.
I solved a similar problem for a programming contest tiling a long hallway with tiles of various shapes. I used dynamic programming: given any panel, there is a way to construct it by laying down one row at a time. Each row can have finitely many shapes at its end. So for each number of rows, for each shape, I compute how many ways there are to make that row. (For the bottom row, there is exactly one way to make each shape.) Then the shape of each row determines the number of shapes that the next row can take (i.e. never line up the spaces). This number is finite for each row and in fact because you have only two sizes of bricks, it is going to be small. So you wind up spending constant time per row and the program finishes quickly.
To represent a shape I would just make a list of 4's and 6's, then use this list as a key in a table to store the number of ways to make that shape in row i, for each i.