-
Notifications
You must be signed in to change notification settings - Fork 0
/
multiple_dwelling.pl
executable file
·77 lines (62 loc) · 2.46 KB
/
multiple_dwelling.pl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
#!/usr/bin/env perl
#--------------------------------------.
# Dinesman's multiple-dwelling problem |
#--------------------------------------'
# For the task: https://rosettacode.org/wiki/Dinesman%27s_multiple-dwelling_problem
# Language: Perl
# Author: Sam S <[email protected]>
use strict;
use warnings;
use feature qw(state say);
use List::Util 1.33 qw(pairmap);
use Algorithm::Permute qw(permute);
our %predicates = (
# | object | sprintf format for Perl expression |
# --------------------+-----------+------------------------------------+
'on bottom' => [ '' , '$f[%s] == 1' ],
'on top' => [ '' , '$f[%s] == @f' ],
'lower than' => [ 'person' , '$f[%s] < $f[%s]' ],
'higher than' => [ 'person' , '$f[%s] > $f[%s]' ],
'directly below' => [ 'person' , '$f[%s] == $f[%s] - 1' ],
'directly above' => [ 'person' , '$f[%s] == $f[%s] + 1' ],
'adjacent to' => [ 'person' , 'abs($f[%s] - $f[%s]) == 1' ],
'on' => [ 'ordinal' , '$f[%s] == \'%s\'' ],
);
our %nouns = (
'person' => qr/[a-z]+/i,
'ordinal' => qr/1st | 2nd | 3rd | \d+th/x,
);
sub parse_and_solve {
my @facts = @_;
state $parser = qr/^(?<subj>$nouns{person}) (?<not>not )?(?|@{[
join '|', pairmap {
"(?<pred>$a)" .
($b->[0] ? " (?<obj>$nouns{$b->[0]})" : '')
} %predicates
]})$/;
my (@expressions, %ids, $i);
my $id = sub { defined $_[0] ? $ids{$_[0]} //= $i++ : () };
foreach (@facts) {
/$parser/ or die "Cannot parse '$_'\n";
my $pred = $predicates{$+{pred}};
my $expr = '(' . sprintf($pred->[1], $id->($+{subj}),
$pred->[0] eq 'person' ? $id->($+{obj}) : $+{obj}). ')';
$expr = '!' . $expr if $+{not};
push @expressions, $expr;
}
my @f = 1..$i;
eval 'no warnings "numeric";
permute {
say join(", ", pairmap { "$f[$b] $a" } %ids)
if ('.join(' && ', @expressions).');
} @f;';
}
parse_and_solve(<DATA>);
__DATA__
Baker not on top
Cooper not on bottom
Fletcher not on top
Fletcher not on bottom
Miller higher than Cooper
Smith not adjacent to Fletcher
Fletcher not adjacent to Cooper