### ----------------------------------------------------
### -- Perl6::Parser
### -- Licenses: Artistic-2.0
### -- Authors: Jeffrey Goff <drforr@pobox.com>
### -- File: t/corpus/rosetta-b.t
### ----------------------------------------------------
### -- Chunk 2 of 2
alts> '}' | \\ .  }
    token alts { <alt>+ % ',' }
    token alt  { ( <meta> | <-[ , } ]> )* }
}

sub crosswalk($/) {
    [X~] '', $0.map: -> $/ { ([$<meta><alts><alt>.&alternatives]) or ~$/ }
}

sub alternatives($_) {
    when :not { () }
    when 1    { '{' X~ $_».&crosswalk X~ '}' }
    default   { $_».&crosswalk }
}

sub brace-expand($s) { crosswalk BraceExpansion.parse($s) }

sub bxtest(*@s) {
    for @s -> $s {
	say "\n$s";
	for brace-expand($s) {
	    say "    ", $_;
	}
    }
}

bxtest Q:to/END/.lines;
    ~/{Downloads,Pictures}/*.{jpg,gif,png}
    It{{em,alic}iz,erat}e{d,}, please.
    {,{,gotta have{ ,\, again\, }}more }cowbell!
    {}} some {\\{edge,edgy} }{ cases, here\\\}
    a{b{1,2}c
    a{1,2}b}c
    a{1,{2},3}b
    a{b{1,2}c{}}
    more{ darn{ cowbell,},}
    ab{c,d\,e{f,g\h},i\,j{k,l\,m}n,o\,p}qr
    {a,{\,b}c
    a{b,{{c}}
    {a{\}b,c}d
    {a,b{{1,2}e}f
    END
_END_
};
]

{ ok round-trips( Q:to[_END_] ), Q{Break OO privacy};
class Foos {
    has $!shyguy = 42;
}
my Foos $foo .= new;

say $foo.^attributes.first('$!shyguy').get_value($foo);
_END_
};

#`{ There's now a check that munges 'CHECK' and 'BEGIN' lines, that may
be causing problems with this particular parse.
{ ok round-trips( Q:to[_END_] ), Q{Brownian tree};
constant size = 100;
constant particlenum = 1_000;
 
 
constant mid = size div 2;
 
my $spawnradius = 5;
my @map;
 
sub set($x, $y) {
    @map[$x][$y] = True;
}
 
sub get($x, $y) {
    return @map[$x][$y] || False;
}
 
set(mid, mid);
my @blocks = " ","\c[UPPER HALF BLOCK]", "\c[LOWER HALF BLOCK]","\c[FULL BLOCK]";
 
sub infix:<█>($a, $b) {
    @blocks[$a + 2 * $b]
}
 
sub display {
    my $start = 0;
    my $end = size;
    say (for $start, $start + 2 ... $end -> $y {
	(for $start..$end -> $x {
	    if abs(($x&$y) - mid) < $spawnradius {
		get($x, $y) █ get($x, $y+1);
	    } else {
		" "
	    }
	}).join
    }).join("\n")
}
 
for ^particlenum -> $progress {
    my Int $x;
    my Int $y;
    my &reset = {
	repeat {
	    ($x, $y) = (mid - $spawnradius..mid + $spawnradius).pick, (mid - $spawnradius, mid + $spawnradius).pick;
	    ($x, $y) = ($y, $x) if (True, False).pick();
	} while get($x,$y);
    }
    reset;

    while not get($x-1|$x|$x+1, $y-1|$y|$y+1) {
	$x = ($x-1, $x, $x+1).pick;
	$y = ($y-1, $y, $y+1).pick;
	if (False xx 3, True).pick {
	    $x = $x >= mid ?? $x - 1 !! $x + 1;
	    $y = $y >= mid ?? $y - 1 !! $y + 1;
	}
	if abs(($x | $y) - mid) > $spawnradius {
	    reset;
	}
    }
    set($x,$y);
    display if $progress %% 50;
    if $spawnradius < mid && abs(($x|$y) - mid) > $spawnradius - 5 {
	$spawnradius = $spawnradius + 1;
    }
}

say "";
display;
say "";
say "time elapsed: ", (now - BEGIN { now }).Num.fmt("%.2f"), " seconds";
say "";
_END_
};
}

{ ok round-trips( Q:to[_END_] ), Q{Bulls and cows};
my $size = 4;
my @secret = pick $size, '1' .. '9';
 
for 1..* -> $guesses {
    my @guess;
    loop {
	@guess = (prompt("Guess $guesses: ") // exit).comb;
	last if @guess == $size and
	    all(@guess) eq one(@guess) & any('1' .. '9');
	say 'Malformed guess; try again.';
    }
    my ($bulls, $cows) = 0, 0;
    for ^$size {
	when @guess[$_] eq @secret[$_] { ++$bulls; }
	when @guess[$_] eq any @secret { ++$cows; }
    }
    last if $bulls == $size;
    say "$bulls bulls, $cows cows.";
}

say 'A winner is you!';
_END_
};

{ ok round-trips( Q:to[_END_] ), Q{Bulls and cows / player};
# we use the [] reduction meta operator along with the Cartesian Product
# operator X to create the Cartesian Product of four times [1..9] and then get
# all the elements where the number of unique digits is four.
my @candidates = ([X] [1..9] xx 4).tree.grep: *.uniq == 4;
 
repeat {
	my $guess = @candidates.pick;
	my ($bulls, $cows) = read-score;
	@candidates .= grep: &score-correct;
 
	# note how we declare our two subroutines within the repeat block. This
	# limits the scope in which the routines are known to the scope in which
	# they are needed and saves us a lot of arguments to our two routines.
	sub score-correct($a) {
		# use the Z (zip) meta operator along with == to construct the
		# list ($a[0] == $b[0], $a[1] == $b[1], ...) and then add it up
		# using the reduction meta operator [] and +.
		my $exact = [+] $a Z== $guess;
 
		# number of elements of $a that match any element of $b
		my $loose = +$a.grep: any @$guess;
 
		return $bulls == $exact && $cows == $loose - $exact;
	}

	sub read-score() {
		loop {
			my $score = prompt "My guess: {$guess.join}.\n";
 
			# use the :s modifier to tell Perl 6 to handle spaces
			# automatically and save the first digit in $<bulls> and
			# the second digit in $<cows>
			if $score ~~ m:s/^ $<bulls>=(\d) $<cows>=(\d) $/
				and $<bulls> + $<cows> <= 4 {
				return +$<bulls>, +$<cows>;
			}
 
			say "Please specify the number of bulls and cows";
		}
	}
} while @candidates > 1;

say @candidates
	?? "Your secret number is {@candidates[0].join}!"
	!! "I think you made a mistake with your scoring.";
_END_
};

done-testing;

#vim: ft=perl6


