December 2012 Archives

Это не вполне решето, так как является не тестом на простоту, а генератором простых чисел. Но принцип прореживания по каждому новому найденному числу остаётся.

#! /usr/bin/perl
use strict;
use warnings;
use 5.010;

use Test::Most;

sub next_int {
	state $i = 2;
	return $i++;
}

sub lazy_grep(&$) {
	my ($filter, $seq) = @_;

	return sub {
		my $next;
		until ($filter->($next = $seq->())) {};
		return $next;
	};
}

sub do_sieve {
	my $f = shift;

	my $nv = $f->();

	return ($nv, lazy_grep { $_[0] % $nv } $f);
}

sub sieve {
	state $next_f = \&next_int;
	my $n;

	($n, $next_f) = do_sieve($next_f);

	return $n;
}

cmp_deeply([sieve, sieve, sieve, sieve], [2, 3, 5, 7]);
cmp_deeply([sieve, sieve, sieve, sieve], [11, 13, 17, 19]);
cmp_deeply([sieve, sieve, sieve, sieve], [23, 29, 31, 37]);

done_testing;

В продолжение к http://friendfeed.com/kkapp/b5d3658c — разбор и вычисление инфиксного арифметического выражения. Потратил несколько часов, и то сошлось только со второго захода. Убил кучу времени на попытки сделать двоичное AST и споткнулся на выражения типа (1 - 2 - 3), где важна ассоциативность слева.

#! /usr/bin/perl
use strict;
use warnings;

use Test::Most;

# expr = sub_expr
#        | sub_expr [+-] expr
# sub_expr = atom
#            | atom [*/] sub_expr
# atom = N
#        | ( expr )
# --->
#[3, +, [ 2, *, 3]]

sub parse_atom {
	if ($_[0] =~ /\G\s*\(/gc) {
		my @val = parse_expr($_[0]);
		$_[0] =~ /\G\s*\)/gc or return undef;
		return ([@val]);
	}

	if ($_[0] =~ /\G\s*([+-]?\d+)/gc) {
		return $1;
	}

	return undef;
}

sub parse_sub_expr {
	my @val = parse_atom($_[0]);

	if ($_[0] =~ /\G\s*([*\/])/gc) {
		push @val, $1;
		push @val, parse_sub_expr($_[0]);
	}

	return @val;
}

sub parse_expr {
	my @val = parse_sub_expr($_[0]);
	if (@val > 1) {
		@val = ([@val]);
	}

	if ($_[0] =~ /\G\s*([+-])/gc) {
		push @val, $1;
		push @val, parse_expr($_[0]);
	}

	return @val;
}

sub parse_calc {
	$_[0] =~ /^/g;
	if (my @val = parse_expr($_[0])) {
		if ($_[0] =~ /\G\s*$/gc) {
			if (@val == 1 && ref $val[0] eq 'ARRAY') {
				return $val[0];
			}
			else {
				return \@val;
			}
		}
	}

	return undef;
}

cmp_deeply(parse_calc('3'), [3]);
cmp_deeply(parse_calc('3 + 2'), [3, '+', 2]);
cmp_deeply(parse_calc('3 - 2 * 1'), [3, '-', [2, '*', 1]]);
cmp_deeply(parse_calc('(3 - 2) / 3'), [[3, '-', 2], '/', 3]);

sub calc { calc_tree(parse_calc($_[0])) }

my %f = (
	'+' => sub { $_[0] + $_[1] },
	'-' => sub { $_[0] - $_[1] },
	'*' => sub { $_[0] * $_[1] },
	'/' => sub { $_[0] / $_[1] },
);

sub calc_tree {
	my $tree = shift;
	unless (ref $tree) {
		return $tree;
	}

	my @rest = @$tree;
	my $head = shift @rest;

	my $rv = calc_tree($head);

	while (@rest >= 2) {
		my ($op, $right) = (shift @rest, shift @rest);
		$rv = $f{$op}->($rv, calc_tree($right));
	}

	return $rv;
}

is(calc('3'), 3);
is(calc('3 + 2'), 5);
is(calc('2 * 2 * 3'), 12);
is(calc('2 * 2 * 2 * 2 * 2'), 32);
is(calc('1+1+1'), 3);
is(calc('4-5+6-7'), -2);
is(calc('100/10*10'), 100);
is(calc('6 / 2 + -1'), 2);
is(calc('(6 + 3) * 2'), 18);
is(calc('((6 + 3) * 2 - 2) / 8'), 2);

done_testing;

Один из простейших эффективных по процессору тестов на простоту чисел с известным серьёзным недостатком — лимитом сверху. Заняло минут 10.

Возможна ленивая реализация. Сделаю отдельно.

#! /usr/bin/perl
use strict;
use warnings;

use Test::Most;

my $TOP = 100000;
our @sieve = 0 .. $TOP;

undef $sieve[1];
for my $i (2 .. $TOP / 2) {
	if ($sieve[$i]) {
		for (my $weed = $i * 2; $weed <= $TOP; $weed += $i) {
			undef $sieve[$weed];
		}
	}
}

sub is_prime {
	my $num = shift;

	return defined $sieve[$num];
}

ok(!is_prime(1));
ok(is_prime(2));
ok(is_prime(3));
ok(!is_prime(4));
ok(!is_prime(9));
ok(!is_prime(10000));
ok(is_prime(8191));
ok(is_prime(86243));
ok(!is_prime(86241));
ok(!is_prime(86242));

done_testing;

Очень приблизительное вычисление числа Пи методом Монте Карло. В продолжение к http://friendfeed.com/kkapp/b5d3658c.

#! /usr/bin/perl
use strict;
use warnings;

my $EPS = 0.001;

sub mt_pi {
	my $radius = shift;

	my ($prev, $cur) = (0, 100);
	my ($count, $count_in) = (0, 0);

	do {
		$prev = $cur;

		for (1 .. 500000) {
			my ($x, $y) = map
				{ rand $radius * 2 - $radius } 0..1;
			++$count;

			if (sqrt($x*$x + $y*$y) <= $radius) {
				++$count_in;
			}
		}

		$cur = 4 * $count_in / $count;
	} while (abs($prev - $cur) > $EPS);

	return $cur;
}

print mt_pi(1), "\n";

Эта задачка началась как regexp matching, но бэктрекингом заниматься желания никакого не было, поэтому сначала сделал автомат, а потом закопался в компиляцию регекспов в NDFA и решил разбить задание на части.

#! /usr/bin/perl
use strict;
use warnings;

use Test::Most;

sub run_automata {
	my ($aut, @symbols) = @_;

	my $cur_state = $aut->{start};

	while (defined(my $symbol = shift @symbols)) {
		$cur_state = $aut->{states}->{$cur_state}->{$symbol}
			// return;
	}

	return $cur_state;
}

my $a1 = {
	states	=> {
		s1	=> { A => 's2', B => 's3' },
		s2	=> { B => 's3' },
		s3	=> { C => 's1' },
	},
	start	=> 's1',
};

is(run_automata($a1, qw/A/), 's2');
is(run_automata($a1, qw/A A/), undef);
is(run_automata($a1, qw//), 's1');
is(run_automata($a1, qw/B/), 's3');
is(run_automata($a1, qw/B C A/), 's2');
is(run_automata($a1, qw/A B C A B C A B C A B C A B/), 's3');
is(run_automata($a1, qw/A X/), undef);
is(run_automata($a1, qw/X/), undef);
is(run_automata($a1, qw/B A/), undef);

sub pairs {
	my ($state, @range) = @_;
	return map { $_ => $state } @range;
}

# [-+]?\d+(\.\d+)?
my $numeric = {
	states	=> {
		nothing		=> { pairs(after_sign => qw/- +/), pairs(in_integer => 0 .. 9) },
		after_sign	=> { pairs(in_integer => 0 .. 9) },
		in_integer	=> { pairs(in_integer => 0 .. 9), '.' => 'decimal', EOF => 'ok' },
		decimal		=> { pairs(in_decimal => 0 .. 9) },
		in_decimal	=> { pairs(in_decimal => 0 .. 9), EOF => 'ok' },
	},
	start	=> 'nothing',
};

is(run_automata($numeric, split('', '-123'), 'EOF'), 'ok', '1st num');
is(run_automata($numeric, split('', '1'), 'EOF'), 'ok');
is(run_automata($numeric, split('', '002'), 'EOF'), 'ok', 'leading zeros');
is(run_automata($numeric, split('', '2.34'), 'EOF'), 'ok');
isnt(run_automata($numeric, split('', '2.'), 'EOF'), 'ok');
isnt(run_automata($numeric, split('', '.3323'), 'EOF'), 'ok');
isnt(run_automata($numeric, split('', 'asd'), 'EOF'), 'ok');
isnt(run_automata($numeric, split('', ''), 'EOF'), 'ok');
isnt(run_automata($numeric, split('', '+.32'), 'EOF'), 'ok');
isnt(run_automata($numeric, split('', '-'), 'EOF'), 'ok');
isnt(run_automata($numeric, split('', '4.4.2'), 'EOF'), 'ok');
done_testing;

В продолжение http://friendfeed.com/kkapp/b5d3658c.

Численные методы вычисления аналитически сложных функций всегда казались очень крутым хаком реальности, жалко, что в работе применить не удалось.

Простейшая численная интеграция линейными функциями. Потратил условный час работы в течение двух дней. Тесты вычислял руками и ВольфрамАльфой.

#! /usr/bin/perl
use strict;
use warnings;

use List::Util qw/sum/;

use Test::Most;
use Test::Number::Delta within => 0.001;
use Data::Dump;

my $EPS = 0.000001;

sub integrate {
	my ($f, $x1, $x2) = @_;

	my $d = 1;
	my ($cur, $prev) = 0;

	do {
		my $dx = ($x2 - $x1) / $d;

		$prev = $cur;
		$cur = sum
			map { $dx * (
				$f->($x1 + $dx * $_)
				+ ($f->($x1 + $dx * ($_ + 1)) - $f->($x1 + $dx * $_)) / 2)
			    } 0 .. ($d - 1);

		$d *= 2;
	}
	while (abs($cur - $prev) > $EPS);

	return $cur;
}

delta_ok(integrate(sub { $_[0] * 10 }, 2, 5), 105);
delta_ok(integrate(sub { 100 - $_[0] * 10 }, 2, 5), 195);
delta_ok(integrate(sub { 3 }, 1, 10), 27);
delta_ok(integrate(sub { -2 * $_[0] }, -3, 4), -7);

delta_ok(integrate(sub { $_[0] ** 2 }, 0, 5), 125/3);
delta_ok(integrate(sub { sin($_[0]) }, 0, 3.1415), 2);
delta_ok(integrate(sub { sin($_[0]) }, 0, 3 * 3.1415), 2);
delta_ok(integrate(sub { -($_[0] ** 4) }, -5, -2), -3093/5);
done_testing;

В продолжение к: http://friendfeed.com/kkapp/b5d3658c

Заняло минут 40. На полпути понял, что останавливаться на первом найденном пути нельзя. В любом случае получился неоптимальный вариант, который на графах с большим количеством дуг может стать кубическим.

#! /usr/bin/perl
use strict;
use warnings;

use Test::Most;
use Data::Dump;

# a graph is stored as its adjacency array:
# for each vertex we have a list of pairs, each containing
# the index of the incident vertex and the weight of the arc to it.

sub spath {
	my ($graph, $from, $to) = @_;

	my @path = (-1) x @$graph;

	my $was_changed = 1;

	$path[$from] = 0;

	while ($was_changed) {
		$was_changed = 0;

		for my $v (grep { $path[$_] != -1 } 0 .. $#path) {
			for my $nv (@{$graph->[$v]}) {
				if  ($path[$nv->[0]] == -1
				  || $path[$nv->[0]] > $path[$v] + $nv->[1])
				{
					$path[$nv->[0]] = $path[$v] + $nv->[1];
					$was_changed = 1;
				}
			}
		}
	}

	return $path[$to];
}

is(spath([[], []], 0, 1), -1);

my $g1 = [
	[[1 => 10], [2 => 21], [3 => 100]],	# 0
	[[2 => 30], [0 => 20], [4 => 50]],	# 1
	[[5 => 40]],				# 2
	[],					# 3
	[],					# 4
	[[5 => 11]],				# 5
];

is(spath($g1, 0, 3), 100);
is(spath($g1, 0, 4), 60);
is(spath($g1, 0, 5), 61);
is(spath($g1, 1, 0), 20);
is(spath($g1, 2, 0), -1);
is(spath($g1, 2, 2), 0);
is(spath($g1, 5, 5), 0);

# A --10-> B --10-> C --10-> D
#  \-----1----------^  ------^
#   \---------1000----/

my $g2 = [
	[[1 => 10], [2 => 1], [3 => 1000]],	# 0
	[[2 => 10]],		# 1
	[[3 => 10]],		# 2
	[],			# 3
];

is(spath($g2, 0, 3), 11);
is(spath($g2, 1, 3), 20);

#  /--1000-v
# A --10-> B --10-> C --10-> D
#  \--------100-----^
#

my $g3 = [
	[[1 => 1000], [1 => 10], [2 => 100]],
	[[2 => 10]],
	[[3 => 10]],
	[],
];

is(spath($g3, 0, 1), 10);
is(spath($g3, 0, 2), 20);

done_testing;

Продолжение http://friendfeed.com/kkapp/b5d3658c.

Уложился быстрее чем вчера, потому что помню, что код упрощается, если границы двигать не на середину, как положено по книжкам, а сразу за неё ($mid ± 1).

#! /usr/bin/perl
use strict;
use warnings;

use Test::Most;
use Data::Dump;

sub bsearch {
	my ($what, @where) = @_;

	my ($left, $right) = (0, $#where);

	while ($right >= $left) {
		my $mid = int(($right - $left) / 2) + $left;

		if	($where[$mid] == $what) {
			return $mid;
		}
		elsif ($where[$mid] < $what) {
			$left = $mid + 1;
		}
		else {
			$right = $mid - 1;
		}
	}

	return -1;
}

is(bsearch(0, 0), 0);
is(bsearch(0, 1), -1);
is(bsearch(1, 1), 0);
is(bsearch(1, 1, 2, 3), 0);
is(bsearch(1, -6, -5, 1, 2, 3), 2);
is(bsearch(0, -6, -5, -3, -1, 0), 4);
is(bsearch(3, 0, 0, 0, 0, 0, 0, 3), 6);
is(bsearch(4, 0, 0, 0, 0, 0, 0, 3), -1);
is(bsearch(1), -1);

done_testing;

Вдогонку к http://friendfeed.com/kkapp/b5d3658c.

Вымучивал полчаса. +Пессимизация по памяти.

#! /usr/bin/perl
use strict;
use warnings;

use Test::Most;
use Data::Dump;

sub msort {
	my @arr = @_;

	if (@arr <= 1) {
		return @arr;
	}

	my $mid = int ($#arr / 2);
	my @left = msort(@arr[0 .. $mid]);
	my @right = msort(@arr[$mid + 1 .. $#arr]);

	my ($li, $ri, @new_arr) = (0, 0);

	while ($li <= $#left || $ri <= $#right) {
		if	($li > $#left) {
			push @new_arr, $right[$ri++];
		}
		elsif	($ri > $#right) {
			push @new_arr, $left[$li++];
		}
		elsif	($right[$ri] < $left[$li]) {
			push @new_arr, $right[$ri++];
		}
		elsif	($left[$li] <= $right[$ri]) {
			push @new_arr, $left[$li++];
		}
		else {
			die "Should not happen";
		}
	}

	return @new_arr;
}

cmp_deeply([msort(1)], [1]);
cmp_deeply([msort(1, 2)], [1, 2]);
cmp_deeply([msort(0, 2)], [0, 2]);
cmp_deeply([msort(0, 1, 2)], [0, 1, 2]);
cmp_deeply([msort(1, 1, 2)], [1, 1, 2]);
cmp_deeply([msort(2, 1, 0)], [0, 1, 2]);
cmp_deeply([msort(1, 0)], [0, 1]);
cmp_deeply([msort(1, 1, 1, 0, 0, 1, 0)], [0, 0, 0, 1, 1, 1, 1]);
cmp_deeply([msort(9, 8, 7, 6, 5, 2, 1)], [1, 2, 5, 6, 7, 8, 9]);
cmp_deeply([msort()], []);
done_testing;