aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Update all new Tasks

Browse source
This commit is contained in:
Ingy döt Net 2015-02-20 09:02:09 -05:00
parent 00a190b0a6
commit 91df62d461
5697 changed files with 93386 additions and 804 deletions
Download patch file Download diff file Expand all files Collapse all files

28
Task/9-billion-names-of-God-the-integer/00DESCRIPTION Normal file
View file

@ -0,0 +1,28 @@
This task is a variation of the [[wp:The Nine Billion Names of God#Plot_summary|short story by Arthur C. Clarke]].
(Solvers should be aware of the consequences of completing this task.)
In detail, to specify what is meant by a “name”:
:The integer 1 has 1 name “1”.
:The integer 2 has 2 names “1+1”, and “2”.
:The integer 3 has 3 names “1+1+1”, “2+1”, and “3”.
:The integer 4 has 5 names “1+1+1+1”, “2+1+1”, “2+2”, “3+1”, “4”.
:The integer 5 has 7 names “1+1+1+1+1”, “2+1+1+1”, “2+2+1”, “3+1+1”, “3+2”, “4+1”, “5”.
;Task
The task is to display the first 25 rows of a number triangle which begins:
<pre>
1
1 1
1 1 1
1 2 1 1
1 2 2 1 1
1 3 3 2 1 1
</pre>
Where row <math>n</math> corresponds to integer <math>n</math>, and each column <math>C</math> in row <math>m</math> from left to right corresponds to the number of names begining with <math>C</math>.
A function <math>G(n)</math> should return the sum of the <math>n</math>-th row. Demonstrate this function by displaying: <math>G(23)</math>, <math>G(123)</math>, <math>G(1234)</math>, and <math>G(12345)</math>.
Optionally note that the sum of the <math>n</math>-th row <math>P(n)</math> is the [http://mathworld.wolfram.com/PartitionFunctionP.html integer partition function]. Demonstrate this is equivalent to <math>G(n)</math> by displaying: <math>P(23)</math>, <math>P(123)</math>, <math>P(1234)</math>, and <math>P(12345)</math>.
;Extra credit
If your environment is able, plot <math>P(n)</math> against <math>n</math> for <math>n=1\ldots 999</math>.

58
Task/9-billion-names-of-God-the-integer/AutoHotkey/9-billion-names-of-god-the-integer.ahk Normal file
View file

@ -0,0 +1,58 @@
SetBatchLines -1
InputBox, Enter_value, Enter the no. of lines sought
array := []
Loop, % 2*Enter_value - 1
Loop, % x := A_Index
y := A_Index, Array[x, y] := 1
x := 3
Loop
{
base_r := x - 1
, x++
, y := 2
, index := x
, new := 1
Loop, % base_r - 1
{
array[x, new+1] := array[x-1, new] + array[base_r, y]
, x++
, new ++
, y++
}
x := index
If ( mod(x,2) = 0 )
{
to_run := floor(x - x/2)
, y2 := to_run + 1
}
Else
{
to_run := x - floor(x/2)
, y2 := to_run
}
Loop, % to_run
{
array[x, y2] := array[x-1, y2-1]
, y2++
If ( y2 = Enter_value + 1 ) && ( x = Enter_value )
{
Loop, % Enter_value
{
Loop, % x11 := A_Index
{
y11 := A_Index
, string2 .= " " array[x11, y11]
}
string2 .= "`n"
}
MsgBox % string2
ExitApp
}
}
}
~Esc::ExitApp

8
Task/9-billion-names-of-God-the-integer/C++/9-billion-names-of-god-the-integer-1.cpp Normal file
View file

@ -0,0 +1,8 @@
// Calculate hypotenuse n of OTT assuming only nothingness, unity, and hyp[n-1] if n>1
// Nigel Galloway, May 6th., 2013
#include <gmpxx.h>
int N{123456};
mpz_class hyp[N-3];
const mpz_class G(const int n,const int g){return g>n?0:(g==1 or n-g<2)?1:hyp[n-g-2];};
void G_hyp(const int n){for(int i=0;i<N-2*n-1;i++) n==1?hyp[n-1+i]=1+G(i+n+1,n+1):hyp[n-1+i]+=G(i+n+1,n+1);}
}

10
Task/9-billion-names-of-God-the-integer/C++/9-billion-names-of-god-the-integer-2.cpp Normal file
View file

@ -0,0 +1,10 @@
#include <iostream>
#include <iomanip>
int main(){
N=25;
for (int n=1; n<N/2; n++){
G_hyp(n);
for (int g=0; g<N-3; g++) std::cout << std::setw(4) << hyp[g];
std::cout << std::endl;
}
}

24
Task/9-billion-names-of-God-the-integer/C++/9-billion-names-of-god-the-integer-3.cpp Normal file
View file

@ -0,0 +1,24 @@
int main(){
N = 25;
std::cout << std::setw(N+52) << "1" << std::endl;
std::cout << std::setw(N+55) << "1 1" << std::endl;
std::cout << std::setw(N+58) << "1 1 1" << std::endl;
std::string ott[N-3];
for (int n=1; n<N/2; n++) {
G_hyp(n);
for (int g=(n-1)*2; g<N-3; g++) {
std::string t = hyp[g-(n-1)].get_str();
//if (t.size()==1) t.insert(t.begin(),1,' ');
ott[g].append(t);
ott[g].append(6-t.size(),' ');
}
}
for(int n = 0; n<N-3; n++) {
std::cout <<std::setw(N+43-3*n) << 1 << " " << ott[n];
for (int g = (n+1)/2; g>0; g--) {
std::string t{hyp[g-1].get_str()};
t.append(6-t.size(),' ');
std::cout << t;
}
std::cout << "1 1" << std::endl;
}

11
Task/9-billion-names-of-God-the-integer/C++/9-billion-names-of-god-the-integer-4.cpp Normal file
View file

@ -0,0 +1,11 @@
#include <iostream>
int main(){
for (int n=1; n<N/2; n++) G_hyp(n);
std::cout << "G(23) = " << hyp[21] << std::endl;
std::cout << "G(123) = " << hyp[121] << std::endl;
std::cout << "G(1234) = " << hyp[1232] << std::endl;
std::cout << "G(12345) = " << hyp[12343] << std::endl;
mpz_class r{3};
for (int i = 0; i<N-3; i++) r += hyp[i];
std::cout << "G(123456) = " << r << std::endl;
}

40
Task/9-billion-names-of-God-the-integer/C/9-billion-names-of-god-the-integer.c Normal file
View file

@ -0,0 +1,40 @@
#include <stdio.h>
#include <gmp.h>
#define N 100000
mpz_t p[N + 1];
void calc(int n)
{
mpz_init_set_ui(p[n], 0);
for (int k = 1; k <= n; k++) {
int d = n - k * (3 * k - 1) / 2;
if (d < 0) break;
if (k&1)mpz_add(p[n], p[n], p[d]);
else mpz_sub(p[n], p[n], p[d]);
d -= k;
if (d < 0) break;
if (k&1)mpz_add(p[n], p[n], p[d]);
else mpz_sub(p[n], p[n], p[d]);
}
}
int main(void)
{
int idx[] = { 23, 123, 1234, 12345, 20000, 30000, 40000, 50000, N, 0 };
int at = 0;
mpz_init_set_ui(p[0], 1);
for (int i = 1; idx[at]; i++) {
calc(i);
if (i != idx[at]) continue;
gmp_printf("%2d:\t%Zd\n", i, p[i]);
at++;
}
}

15
Task/9-billion-names-of-God-the-integer/Common-Lisp/9-billion-names-of-god-the-integer.lisp Normal file
View file

@ -0,0 +1,15 @@
(defun 9-billion-names (row column)
(cond ((<= row 0) 0)
((<= column 0) 0)
((< row column) 0)
((equal row 1) 1)
(t (let ((addend (9-billion-names (1- row) (1- column)))
(augend (9-billion-names (- row column) column)))
(+ addend augend)))))
(defun 9-billion-names-triangle (rows)
(loop for row from 1 to rows
collect (loop for column from 1 to row
collect (9-billion-names row column))))
(9-billion-names-triangle 25)

27
Task/9-billion-names-of-God-the-integer/D/9-billion-names-of-god-the-integer-1.d Normal file
View file

@ -0,0 +1,27 @@
import std.stdio, std.bigint, std.algorithm, std.range;
auto cumu(in uint n) {
__gshared cache = [[1.BigInt]];
foreach (l; cache.length .. n + 1) {
auto r = [0.BigInt];
foreach (x; 1 .. l + 1)
r ~= r.back + cache[l - x][min(x, l - x)];
cache ~= r;
}
return cache[n];
}
auto row(in uint n) {
auto r = n.cumu;
return n.iota.map!(i => r[i + 1] - r[i]);
}
void main() {
writeln("Rows:");
foreach (x; 1 .. 11)
writefln("%2d: %s", x, x.row);
writeln("\nSums:");
foreach (x; [23, 123, 1234])
writeln(x, " ", x.cumu.back);
}

51
Task/9-billion-names-of-God-the-integer/D/9-billion-names-of-god-the-integer-2.d Normal file
View file

@ -0,0 +1,51 @@
import std.stdio, std.bigint, std.algorithm;
struct Names {
BigInt[] p = [1.BigInt];
int opApply(int delegate(ref immutable int, ref BigInt) dg) {
int result;
foreach (immutable n; 1 .. int.max) {
p.assumeSafeAppend;
p ~= 0.BigInt;
foreach (immutable k; 1 .. n + 1) {
auto d = n - k * (3 * k - 1) / 2;
if (d < 0)
break;
if (k & 1)
p[n] += p[d];
else
p[n] -= p[d];
d -= k;
if (d < 0)
break;
if (k & 1)
p[n] += p[d];
else
p[n] -= p[d];
}
result = dg(n, p[n]);
if (result) break;
}
return result;
}
}
void main() {
immutable ns = [23:0, 123:0, 1234:0, 12345:0];
immutable maxNs = ns.byKey.reduce!max;
foreach (immutable i, p; Names()) {
if (i > maxNs)
break;
if (i in ns)
writefln("%6d: %s", i, p);
}
}

29
Task/9-billion-names-of-God-the-integer/Erlang/9-billion-names-of-god-the-integer.erl Normal file
View file

@ -0,0 +1,29 @@
-module(god_the_integer).
-export([example/0, names/1, print_pyramid/1]).
example() ->
Names = names( 10 ),
print_pyramid( Names ).
names( N ) ->
[names_row(X) || X <- lists:seq(1, N)].
print_pyramid( Names ) ->
Width = erlang:length( lists:last(Names) ),
[print_pyramid_row(Width, X) || X <- Names].
names_row( M ) ->
[p(M, X) || X <- lists:seq(1, M)].
p( N, K ) when K > N -> 0;
p( N, N ) -> 1;
p( _N, 0 ) -> 0;
p( N, K ) ->
p( N - 1, K - 1 ) + p( N - K, K ).
print_pyramid_row( Width, Row ) ->
io:fwrite( "~*s", [Width - erlang:length(Row), " "] ),
[io:fwrite("~p ", [X]) || X <- Row],
io:nl().

54
Task/9-billion-names-of-God-the-integer/Frink/9-billion-names-of-god-the-integer.frink Normal file
View file

@ -0,0 +1,54 @@
class PartitionCount
{
// Array of elements
class var triangle = [[0],[0,1]]
// Array of cumulative sums in each row.
class var sumTriangle = [[1],[0,1]]
class calcRowsTo[toRow] :=
{
for row = length[triangle] to toRow
{
triangle@row = workrow = new array[[row+1],0]
sumTriangle@row = sumworkrow = new array[[row+1],0]
oversum = 0
for col = 1 to row
{
otherRow = row-col
sum = sumTriangle@otherRow@min[col,otherRow]
workrow@col = sum
oversum = oversum + sum
sumworkrow@col = oversum
}
}
}
class rowSum[row] :=
{
calcRowsTo[row]
return sumTriangle@row@row
}
}
PartitionCount.calcRowsTo[25]
for row=1 to 25
{
for col=1 to row
print[PartitionCount.triangle@row@col + " "]
println[]
}
// Test against Frink's built-in much faster partitionCount function that uses
// Euler's pentagonal method for counting partitions.
testRow[row] :=
{
sum = PartitionCount.rowSum[row]
println["$row\t$sum\t" + (sum == partitionCount[row] ? "correct" : "incorrect")]
}
println[]
testRow[23]
testRow[123]
testRow[1234]
testRow[12345]

21
Task/9-billion-names-of-God-the-integer/Haskell/9-billion-names-of-god-the-integer-1.hs Normal file
View file

@ -0,0 +1,21 @@
import Data.List (mapAccumL)
cumu :: [[Integer]]
cumu = [1] : map (scanl (+) 0) rows
rows :: [[Integer]]
rows = snd $ mapAccumL f [] cumu where
f r row = (rr, new_row) where
new_row = map head rr
rr = map tailKeepOne (row:r)
tailKeepOne [x] = [x]
tailKeepOne (_:xs) = xs
sums n = cumu !! n !! n
--curiously, the following seems to be faster
--sums = sum . (rows!!)
main :: IO ()
main = do
mapM_ print $ take 10 rows
mapM_ (print.sums) [23, 123, 1234, 12345]

25
Task/9-billion-names-of-God-the-integer/Haskell/9-billion-names-of-god-the-integer-2.hs Normal file
View file

@ -0,0 +1,25 @@
procedure main(A)
n := integer(!A) | 10
every r := 2 to (n+1) do write(right(r-1,2),": ",showList(row(r)))
write()
every r := 23 | 123 | 1234 | 12345 do write(r," ",cumu(r+1)[-1])
end
procedure cumu(n)
static cache
initial cache := [[1]]
every l := *cache to n do {
every (r := [0], x := !l) do put(r, r[-1]+cache[1+l-x][1+min(x,l-x)])
put(cache, r)
}
return cache[n]
end
procedure row(n)
return (r := cumu(n), [: (i := !(*r-1), r[i+1]-r[i]) :]) | r
end
procedure showList(A)
every (s := "[") ||:= (!A||", ")
return s[1:-2]||"]"
end

1
Task/9-billion-names-of-God-the-integer/J/9-billion-names-of-god-the-integer-1.j Normal file
View file

@ -0,0 +1 @@
T=: 0:`1:`(($:&<:+ - $: ])`0:@.(0=]))@.(1+*@-) M. "0

1
Task/9-billion-names-of-God-the-integer/J/9-billion-names-of-god-the-integer-2.j Normal file
View file

@ -0,0 +1 @@
rows=: <@(#~0<])@({: T ])\@i.

11
Task/9-billion-names-of-God-the-integer/J/9-billion-names-of-god-the-integer-3.j Normal file
View file

@ -0,0 +1,11 @@
({.~1+1 i:~ '1'=])"1 ":> }.rows 1+10
1
1 1
1 1 1
1 2 1 1
1 2 2 1 1
1 3 3 2 1 1
1 3 4 3 2 1 1
1 4 5 5 3 2 1 1
1 4 7 6 5 3 2 1 1
1 5 8 9 7 5 3 2 1 1

11
Task/9-billion-names-of-God-the-integer/J/9-billion-names-of-god-the-integer-4.j Normal file
View file

@ -0,0 +1,11 @@
rowSums=: 3 :0"0
z=. (y+1){. 1x
for_ks. <\1+i.y do.
n=.{: k=.>ks
r=.#c=. ({.~* i._1:)(n,0.5 _1.5) p. k
s=.#d=.({.~* i._1:)c-r{.k
'v i'=.|: \:~(c,d),. r ,&({.&k) s
a=. +/(n{z),(_1^1x+2|i) * v{z
z=. a n}z
end.
)

57
Task/9-billion-names-of-God-the-integer/JavaScript/9-billion-names-of-god-the-integer.js Normal file
View file

@ -0,0 +1,57 @@
(function () {
var cache = [
[1]
];
//this was never needed.
/* function PyRange(start, end, step) {
step = step || 1;
if (!end) {
end = start;
start = 0;
}
var arr = [];
for (var i = start; i < end; i += step) arr.push(i);
return arr;
}*/
function cumu(n) {
var /*ra = PyRange(cache.length, n + 1),*/ //Seems there is a better version for this
r, l, x, Aa, Mi;
// for (ll in ra) { too pythony
for (l=cache.length;l<n+1;l++) {
r = [0];
// l = ra[ll];
// ran = PyRange(1, l + 1);
// for (xx in ran) {
for(x=1;x<l+1;x++){
// x = ran[xx];
r.push(r[r.length - 1] + (Aa = cache[l - x < 0 ? cache.length - (l - x) : l - x])[(Mi = Math.min(x, l - x)) < 0 ? Aa.length - Mi : Mi]);
}
cache.push(r);
}
return cache[n];
}
function row(n) {
var r = cumu(n),
// rra = PyRange(n),
leArray = [],
i;
// for (ii in rra) {
for (i=0;i<n;i++) {
// i = rra[ii];
leArray.push(r[i + 1] - r[i]);
}
return leArray;
}
console.log("Rows:");
for (iterator = 1; iterator < 12; iterator++) {
console.log(row(iterator));
}
console.log("Sums")[23, 123, 1234, 12345].foreach(function (a) {
var s = cumu(a);
console.log(a, s[s.length - 1]);
});
})()

1
Task/9-billion-names-of-God-the-integer/Mathematica/9-billion-names-of-god-the-integer-1.math Normal file
View file

@ -0,0 +1 @@
Table[Last /@ Reverse@Tally[First /@ IntegerPartitions[n]], {n, 10}] // Grid

1
Task/9-billion-names-of-God-the-integer/Mathematica/9-billion-names-of-god-the-integer-2.math Normal file
View file

@ -0,0 +1 @@
PartitionsP /@ {23, 123, 1234, 12345}

1
Task/9-billion-names-of-God-the-integer/Mathematica/9-billion-names-of-god-the-integer-3.math Normal file
View file

@ -0,0 +1 @@
DiscretePlot[PartitionsP[n], {n, 1, 999}, PlotRange -> All]

78
Task/9-billion-names-of-God-the-integer/OCaml/9-billion-names-of-god-the-integer.ocaml Normal file
View file

@ -0,0 +1,78 @@
let get, sum_unto =
let cache = ref [||]
let rec get i j =
if Array.length !cache < i then
cache :=
Array.init i begin fun i ->
try !cache.(i) with Invalid_argument _ ->
Array.make (i+1) (Num.num_of_int 0)
end;
if Num.(!cache.(i-1).(j-1) =/ num_of_int 0)
then !cache.(i-1).(j-1) <- sum_unto (i-j) j;
!cache.(i-1).(j-1)
and sum_unto i j =
let rec sum_unto sum i j =
match (i,j) with
|(0,0) -> (Num.num_of_int 1)
|(_,0) -> sum
|(i,j) when j > i -> sum_unto sum i i
|(i,j) -> sum_unto Num.(sum +/ (get i j)) i (j-1)
in
sum_unto (Num.num_of_int 0) i j
in
get, sum_unto
let sum_of_row n = sum_unto n n
let euler_recurrence =
let cache = ref [||] in
let rec recurrence = function
|n when n < 0 -> Num.num_of_int 0
|0 -> Num.num_of_int 1
|n ->
if n >= Array.length !cache then
cache :=
Array.init (n+1) (fun i ->
try !cache.(i) with Invalid_argument _ -> Num.num_of_int 0);
if Num.(!cache.(n) =/ num_of_int 0)
then begin
let rec summing sum = function
|0 -> sum
|k ->
let op = if k mod 2 = 0 then Num.sub_num else Num.add_num in
let sum = op sum (recurrence (n - k * (3*k - 1) / 2)) in
let sum = op sum (recurrence (n - k * (3*k + 1) / 2)) in
summing sum (k-1)
in
!cache.(n) <- summing (Num.num_of_int 0) n
end;
!cache.(n)
in
recurrence
let print i_max =
for i=1 to i_max do
print_int (i+1); print_string ": ";
for j=1 to i do
print_string (Num.string_of_num (get i j));
print_char ' ';
done;
print_newline ();
done
let () =
print 30;
print_newline ();
List.iter begin fun i ->
Printf.printf "%i: %s ?= %s\n" i
(Num.string_of_num (sum_of_row i))
(Num.string_of_num (euler_recurrence i));
flush stdout;
end
[23;123;1234;];
List.iter begin fun i ->
Printf.printf "%i: %s\n" i
(Num.string_of_num (euler_recurrence i));
flush stdout;
end
[23;123;1234;12345;123456]

29
Task/9-billion-names-of-God-the-integer/Perl-6/9-billion-names-of-god-the-integer.pl6 Normal file
View file

@ -0,0 +1,29 @@
my @todo = [1];
my @sums = 0;
sub nextrow($n) {
for +@todo .. $n -> $l {
@sums[$l] = 0;
print $l,"\r" if $l < $n;
my $r = [];
for reverse ^$l -> $x {
my @x := @todo[$x];
if @x {
$r.push: @sums[$x] += @x.shift;
}
else {
$r.push: @sums[$x];
}
}
@todo.push($r);
}
@todo[$n];
}
say "rows:";
say .fmt('%2d'), ": ", nextrow($_)[] for 1..10;
say "\nsums:";
for 23, 123, 1234, 10000 {
say $_, "\t", [+] nextrow($_)[];
}

12
Task/9-billion-names-of-God-the-integer/Perl/9-billion-names-of-god-the-integer-1.pl Normal file
View file

@ -0,0 +1,12 @@
use ntheory qw/:all/;
sub triangle_row {
my($n,@row) = (shift);
# Tally by first element of the unrestricted integer partitions.
forpart { $row[ $_[0] - 1 ]++ } $n;
@row;
}
printf "%2d: %s\n", $_, join(" ",triangle_row($_)) for 1..25;
print "\n";
say "P($_) = ", partitions($_) for (23, 123, 1234, 12345);

40
Task/9-billion-names-of-God-the-integer/Perl/9-billion-names-of-god-the-integer-2.pl Normal file
View file

@ -0,0 +1,40 @@
use strict;
use warnings;
# Where perl6 uses arbitrary precision integers everywhere
# that you don't tell it not to do so, perl5 will only use
# them where you *do* tell it do so.
use Math::BigInt;
use constant zero => Math::BigInt->bzero;
use constant one => Math::BigInt->bone;
my @todo = [one];
my @sums = (zero);
sub nextrow {
my $n = shift;
for my $l (@todo .. $n) {
$sums[$l] = zero;
#print "$l\r" if $l < $n;
my @r;
for my $x (reverse 0 .. $l-1) {
my $todo = $todo[$x];
$sums[$x] += shift @$todo if @$todo;
push @r, $sums[$x];
}
push @todo, \@r;
}
@{ $todo[$n] };
}
print "rows:\n";
for(1..25) {
printf("%2d: ", $_);
print join(' ', nextrow($_)), "\n";
}
print "\nsums:\n";
for (23, 123, 1234, 12345) {
print $_, "." x (8 - length);
my $i = 0;
$i += $_ for nextrow($_);
print $i, "\n";
}

52
Task/9-billion-names-of-God-the-integer/PicoLisp/9-billion-names-of-god-the-integer.l Normal file
View file

@ -0,0 +1,52 @@
(de row (N)
(let C '((1))
(do N
(push 'C (grow C)) )
(mapcon
'((L)
(when (cdr L)
(cons (- (cadr L) (car L))) ) )
(car C) ) ) )
(de grow (Lst)
(let (L (length Lst) S 0)
(cons
0
(mapcar
'((I X)
(inc 'S
(get I (inc (min X (- L X)))) ) )
Lst
(range 1 L) ) ) ) )
(de sumr (N)
(let
(K 1
S 1
O (cons 1 (need N 0))
D
(make
(while
(<
(* K (dec (* 3 K)))
(* 2 N) )
(link (list (dec (* 2 K)) S))
(link (list K S))
(inc 'K)
(setq S (- S)) ) ) )
(for (Y O (cdr Y) (cdr Y))
(let Z Y
(for L D
(inc
(setq Z (cdr (nth Z (car L))))
(* (car Y) (cadr L)) ) ) ) )
(last O) ) )
(for I 25
(println (row I)) )
(bench
(for I '(23 123 1234 12345)
(println (sumr I)) ) )
(bye)

19
Task/9-billion-names-of-God-the-integer/Python/9-billion-names-of-god-the-integer-1.py Normal file
View file

@ -0,0 +1,19 @@
cache = [[1]]
def cumu(n):
for l in range(len(cache), n+1):
r = [0]
for x in range(1, l+1):
r.append(r[-1] + cache[l-x][min(x, l-x)])
cache.append(r)
return cache[n]
def row(n):
r = cumu(n)
return [r[i+1] - r[i] for i in range(n)]
print "rows:"
for x in range(1, 11): print "%2d:"%x, row(x)
print "\nsums:"
for x in [23, 123, 1234, 12345]: print x, cumu(x)[-1]

18
Task/9-billion-names-of-God-the-integer/Python/9-billion-names-of-god-the-integer-2.py Normal file
View file

@ -0,0 +1,18 @@
def partitions(N):
diffs,k,s = [],1,1
while k * (3*k-1) < 2*N:
diffs.extend([(2*k - 1, s), (k, s)])
k,s = k+1,-s
out = [1] + [0]*N
for p in range(0, N+1):
x = out[p]
for (o,s) in diffs:
p += o
if p > N: break
out[p] += x*s
return out
p = partitions(12345)
for x in [23,123,1234,12345]: print x, p[x]

38
Task/9-billion-names-of-God-the-integer/Python/9-billion-names-of-god-the-integer-3.py Normal file
View file

@ -0,0 +1,38 @@
def partitions(n):
partitions.p.append(0)
for k in xrange(1, n + 1):
d = n - k * (3 * k - 1) // 2
if d < 0:
break
if k & 1:
partitions.p[n] += partitions.p[d]
else:
partitions.p[n] -= partitions.p[d]
d -= k
if d < 0:
break
if k & 1:
partitions.p[n] += partitions.p[d]
else:
partitions.p[n] -= partitions.p[d]
return partitions.p[-1]
partitions.p = [1]
def main():
ns = set([23, 123, 1234, 12345])
max_ns = max(ns)
for i in xrange(1, max_ns + 1):
if i > max_ns:
break
p = partitions(i)
if i in ns:
print "%6d: %s" % (i, p)
main()

1
Task/9-billion-names-of-God-the-integer/README Normal file
View file

@ -0,0 +1 @@
Data source: http://rosettacode.org/wiki/9_billion_names_of_God_the_integer

52
Task/9-billion-names-of-God-the-integer/REXX/9-billion-names-of-god-the-integer.rexx Normal file
View file

@ -0,0 +1,52 @@
/*REXX program generates a number triangle for partitions of a number.*/
numeric digits 400 /*be able to handle large numbers*/
parse arg N .; if N=='' then N=25 /*No input? Then use the default*/
@.=0; @.0=1; aN=abs(N)
if N==N+0 then say ' G('aN"):" G(N) /*just for well formed #s*/
say 'partitions('aN"):" partitions(aN) /*the easy way*/
exit /*stick a fork in it, we're done.*/
/*──────────────────────────────────G subroutine────────────────────────*/
G: procedure; parse arg nn; !.=0; mx=1; aN=abs(nn); build=nn>0
!.4.2=2; do j=1 for aN%2; !.j.j=1; end /*j*/ /*shortcuts.*/
do t=1 for 1+build; #.=1 /*gen triangle once or twice ∙∙∙*/
do r=1 for aN; #.2=r%2 /*#.2 is a shortcut calc.*/
do c=3 to r-2; #.c=gen#(r,c); end /*c*/
L=length(mx); p=0; aLine=
do cc=1 for r /*only sum last row of numbers. */
p=p+#.cc /*add last row of the triangle. */
if \build then iterate /*skip building the triangle? */
mx=max(mx,#.cc) /*used to build symmetric numbers*/
aLine=aLine right(#.cc,L) /*build a row of the triangle. */
end /*cc*/
if t==1 then iterate /*Is first time through? No show*/
L=length(mx); say centre(strip(aLine,'L'), 2+(aN-1)*(L+1))
end /*r*/ /* [↑] centre the row (triangle).*/
end /*t*/
return p /*return with generated number. */
/*──────────────────────────────────GEN# subroutine─────────────────────*/
gen#: procedure expose !.; parse arg x,y /*obtain X and Y arguments.*/
if !.x.y\==0 then return !.x.y /*was this # generated before? */
if y>x%2 then do; nx=x+1-2*(y-x%2)-(x//2==0); ny=nx%2; !.x.y=!.nx.ny
return !.x.y /*return with the calculated num.*/
end /*[↑] right half of the triangle.*/
$=1 /*[↓] left half of the triangle.*/
do q=2 to y; xy=x-y; if q>xy then iterate
if q==2 then $=$+xy%2
else if q==xy-1 then $=$+1
else $=$+gen#(xy,q)
end /*q*/
!.x.y=$; return $ /*remember #, return with number.*/
/*──────────────────────────────────PARTITIONS subroutine───────────────*/
partitions: procedure expose @.; parse arg n
if @.n\==0 then return @.n /*Already computed? Return it. */
$=0 /*[↓] Euler's recursive function.*/
do k=1 for n; _=n-(k*3-1)*k%2; if _<0 then leave
if @._==0 then x=partitions(_); else x=@._
_=_-k; if _<0 then y=0
else if @._==0 then y=partitions(_)
else y=@._
if k//2 then $=$+x+y /*sum this way if K is odd ···*/
else $=$-x-y /* " " " " " " even ···*/
end /*k*/
@.n=$; return $

23
Task/9-billion-names-of-God-the-integer/Racket/9-billion-names-of-god-the-integer.rkt Normal file
View file

@ -0,0 +1,23 @@
#lang racket
(define (cdr-empty ls) (if (empty? ls) empty (cdr ls)))
(define (names-of n)
(define (names-of-tail ans raws-rest n)
(if (zero? n)
ans
(names-of-tail (cons 1 (append (map +
(take ans (length raws-rest))
(map car raws-rest))
(drop ans (length raws-rest))))
(filter (compose not empty?)
(map cdr-empty (cons ans raws-rest)))
(sub1 n))))
(names-of-tail '() '() n))
(define (G n) (foldl + 0 (names-of n)))
(module+ main
(build-list 25 (compose names-of add1))
(newline)
(map G '(23 123 1234)))

10
Task/9-billion-names-of-God-the-integer/Ruby/9-billion-names-of-god-the-integer-1.rb Normal file
View file

@ -0,0 +1,10 @@
# Generate IPF triangle
# Nigel_Galloway: May 1st., 2013.
def g(n,g)
return 1 unless 1 < g and g < n-1
(2..g).inject(1){|res,q| res + (q > n-g ? 0 : g(n-g,q))}
end
(1..25).each {|n|
puts (1..n).map {|g| "%4s" % g(n,g)}.join
}

30
Task/9-billion-names-of-God-the-integer/Ruby/9-billion-names-of-god-the-integer-2.rb Normal file
View file

@ -0,0 +1,30 @@
# Find large values of IPF
# Nigel_Galloway: May 1st., 2013.
N = 12345
@ng = []
@ipn1 = []
@ipn2 = []
def g(n,g)
t = n-g-2
return 1 if n<4 or t<0
return @ng[g-2][n-4] unless n/2<g
return @ipn1[t]
end
@ng[0] = []
(4..N).each {|q| @ng[0][q-4] = 1 + g(q-2,2)}
@ipn1[0] = @ng[0][0]
@ipn2[0] = @ng[0][N-4]
(1...(N/2-1)).each {|n|
@ng[n] = []
(n*2+4..N).each {|q| @ng[n][q-4] = g(q-1,n+1) + g(q-n-2,n+2)}
@ipn1[n] = @ng[n][n*2]
@ipn2[n] = @ng[n][N-4]
@ng[n-1] = nil
}
@ipn2.pop if N.even?
puts "G(23) = #{@ipn1[21]}"
puts "G(123) = #{@ipn1[121]}"
puts "G(1234) = #{@ipn1[1232]}"
n = 3 + @ipn1.inject(:+) + @ipn2.inject(:+)
puts "G(12345) = #{n}"

36
Task/9-billion-names-of-God-the-integer/Scala/9-billion-names-of-god-the-integer-1.scala Normal file
View file

@ -0,0 +1,36 @@
object Main {
// This is a special class for memoization
case class Memo[A,B](f: A => B) extends (A => B) {
private val cache = Map.empty[A, B]
def apply(x: A) = cache getOrElseUpdate (x, f(x))
}
// Naive, but memoized solution
lazy val namesStartingMemo : Memo[Tuple2[Int, Int], BigInt] = Memo {
case (1, 1) => 1
case (a, n) =>
if (a > n/2) namesStartingMemo(a - 1, n - 1)
else if (n < a) 0
else if (n == a) 1
else (1 to a).map(i => namesStartingMemo(i, n - a)).sum
}
def partitions(n: Int) = (1 to n).map(namesStartingMemo(_, n)).sum
// main method
def main(args: Array[String]): Unit = {
for (i <- 1 to 25) {
for (j <- 1 to i) {
print(namesStartingMemo(j, i));
print(' ');
}
println()
}
println(partitions(23))
println(partitions(123))
println(partitions(1234))
println(partitions(12345))
}
}

49
Task/9-billion-names-of-God-the-integer/Scala/9-billion-names-of-god-the-integer-2.scala Normal file
View file

@ -0,0 +1,49 @@
val cache = new Array[BigInt](15000)
cache(0) = 1
val cacheNaive = scala.collection.mutable.Map[Tuple2[Int, Int], BigInt]()
def p(n: Int, k: Int): BigInt = cacheNaive.getOrElseUpdate((n, k), (n, k) match {
case (n, 1) => 1
case (n, k) if n < k => 0
case (n, k) if n == k => 1
case (n, k) =>
if (k > n/2) p(n - 1, k - 1)
else p(n - 1, k - 1) + p(n - k, k)
})
def partitions(n: Int) = (1 to n).map(p(n, _)).sum
def updateCache(n: Int, d: Int, k: Int) =
if ((k & 1) == 1) cache(n) = cache(n) + cache(d)
else cache(n) = cache(n) - cache(d)
def quickPartitions(n: Int): BigInt = {
cache(n) = 0
for (k <- 1 to n) {
val d = n - k * (3 * k - 1) / 2
if (d >= 0) {
updateCache(n, d, k)
val e = d - k
if (e >= 0) {
updateCache(n, e, k)
}
}
}
cache(n)
}
for (i <- 1 to 23) {
for (j <- 1 to i) {
print(f"${p(i, j)}%4d")
}
println
}
println(partitions(23))
for (i <- 1 until cache.length) {
quickPartitions(i)
}
println(quickPartitions(123))
println(quickPartitions(1234))
println(quickPartitions(12345))

30
Task/9-billion-names-of-God-the-integer/Tcl/9-billion-names-of-god-the-integer.tcl Normal file
View file

@ -0,0 +1,30 @@
set cache 1
proc cumu {n} {
global cache
for {set l [llength $cache]} {$l <= $n} {incr l} {
set r 0
for {set x 1; set y [expr {$l-1}]} {$y >= 0} {incr x; incr y -1} {
lappend r [expr {
[lindex $r end] + [lindex $cache $y [expr {min($x, $y)}]]
}]
}
lappend cache $r
}
return [lindex $cache $n]
}
proc row {n} {
set r [cumu $n]
for {set i 0; set j 1} {$j < [llength $r]} {incr i; incr j} {
lappend result [expr {[lindex $r $j] - [lindex $r $i]}]
}
return $result
}
puts "rows:"
foreach x {1 2 3 4 5 6 7 8 9 10} {
puts "${x}: \[[join [row $x] {, }]\]"
}
puts "\nsums:"
foreach x {23 123 1234 12345} {
puts "${x}: [lindex [cumu $x] end]"
}

48
Task/ABC-Problem/00DESCRIPTION Normal file
View file

@ -0,0 +1,48 @@
You are given a collection of ABC blocks. Just like the ones you had when you were a kid. There are twenty blocks with two letters on each block. You are guaranteed to have a complete alphabet amongst all sides of the blocks. The sample blocks are:
:((B O)
: (X K)
: (D Q)
: (C P)
: (N A)
: (G T)
: (R E)
: (T G)
: (Q D)
: (F S)
: (J W)
: (H U)
: (V I)
: (A N)
: (O B)
: (E R)
: (F S)
: (L Y)
: (P C)
: (Z M))
The goal of this task is to write a function that takes a string and can determine whether you can spell the word with the given collection of blocks.
The rules are simple:
#Once a letter on a block is used that block cannot be used again
#The function should be case-insensitive
# Show your output on this page for the following words:
;Example:
<lang python>
>>> can_make_word("A")
True
>>> can_make_word("BARK")
True
>>> can_make_word("BOOK")
False
>>> can_make_word("TREAT")
True
>>> can_make_word("COMMON")
False
>>> can_make_word("SQUAD")
True
>>> can_make_word("CONFUSE")
True
</lang>

78
Task/ABC-Problem/Ada/abc-problem.ada Normal file
View file

@ -0,0 +1,78 @@
with Ada.Characters.Handling;
use Ada.Characters.Handling;
package Abc is
type Block_Faces is array(1..2) of Character;
type Block_List is array(positive range <>) of Block_Faces;
function Can_Make_Word(W: String; Blocks: Block_List) return Boolean;
end Abc;
package body Abc is
function Can_Make_Word(W: String; Blocks: Block_List) return Boolean is
Used : array(Blocks'Range) of Boolean := (Others => False);
subtype wIndex is Integer range W'First..W'Last;
wPos : wIndex;
begin
if W'Length = 0 then
return True;
end if;
wPos := W'First;
while True loop
declare
C : Character := To_Upper(W(wPos));
X : constant wIndex := wPos;
begin
for I in Blocks'Range loop
if (not Used(I)) then
if C = To_Upper(Blocks(I)(1)) or C = To_Upper(Blocks(I)(2)) then
Used(I) := True;
if wPos = W'Last then
return True;
end if;
wPos := wIndex'Succ(wPos);
exit;
end if;
end if;
end loop;
if X = wPos then
return False;
end if;
end;
end loop;
return False;
end Can_Make_Word;
end Abc;
with Ada.Text_IO, Ada.Strings.Unbounded, Abc;
use Ada.Text_IO, Ada.Strings.Unbounded, Abc;
procedure Abc_Problem is
Blocks : Block_List := (
('B','O'), ('X','K'), ('D','Q'), ('C','P')
, ('N','A'), ('G','T'), ('R','E'), ('T','G')
, ('Q','D'), ('F','S'), ('J','W'), ('H','U')
, ('V','I'), ('A','N'), ('O','B'), ('E','R')
, ('F','S'), ('L','Y'), ('P','C'), ('Z','M')
);
function "+" (S : String) return Unbounded_String renames To_Unbounded_String;
words : array(positive range <>) of Unbounded_String := (
+"A"
, +"BARK"
, +"BOOK"
, +"TREAT"
, +"COMMON"
, +"SQUAD"
, +"CONFUSE"
-- Border cases:
-- , +"CONFUSE2"
-- , +""
);
begin
for I in words'Range loop
Put_Line ( To_String(words(I)) & ": " & Boolean'Image(Can_Make_Word(To_String(words(I)),Blocks)) );
end loop;
end Abc_Problem;

24
Task/ABC-Problem/AutoHotkey/abc-problem-1.ahk Normal file
View file

@ -0,0 +1,24 @@
isWordPossible(blocks, word){
o := {}
loop, parse, blocks, `n, `r
o.Insert(A_LoopField)
loop, parse, word
if !(r := isWordPossible_contains(o, A_LoopField, word))
return 0
return 1
}
isWordPossible_contains(byref o, letter, word){
loop 2 {
for k,v in o
if Instr(v,letter)
{
StringReplace, op, v,% letter
if RegExMatch(op, "[" word "]")
sap := k
else added := 1 , sap := k
if added
return "1" o.remove(sap)
}
added := 1
}
}

38
Task/ABC-Problem/AutoHotkey/abc-problem-2.ahk Normal file
View file

@ -0,0 +1,38 @@
blocks := "
(
BO
XK
DQ
CP
NA
GT
RE
TG
QD
FS
JW
HU
VI
AN
OB
ER
FS
LY
PC
ZM
)"
wordlist := "
(
A
BARK
BOOK
TREAT
COMMON
SQUAD
CONFUSE
)"
loop, parse, wordlist, `n
out .= A_LoopField " - " isWordPossible(blocks, A_LoopField) "`n"
msgbox % out

22
Task/ABC-Problem/BBC-BASIC/abc-problem.bbc Normal file
View file

@ -0,0 +1,22 @@
BLOCKS$="BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"
PROCcan_make_word("A")
PROCcan_make_word("BARK")
PROCcan_make_word("BOOK")
PROCcan_make_word("TREAT")
PROCcan_make_word("COMMON")
PROCcan_make_word("SQUAD")
PROCcan_make_word("Confuse")
END
DEF PROCcan_make_word(word$)
LOCAL b$,p%
b$=BLOCKS$
PRINT word$ " -> ";
p%=INSTR(b$,CHR$(ASCword$ AND &DF))
WHILE p%>0 AND word$>""
MID$(b$,p%-1+(p% MOD 2),2)=".."
word$=MID$(word$,2)
p%=INSTR(b$,CHR$(ASCword$ AND &DF))
ENDWHILE
IF word$>"" PRINT "False" ELSE PRINT "True"
ENDPROC

62
Task/ABC-Problem/Batch-File/abc-problem.bat Normal file
View file

@ -0,0 +1,62 @@
@echo off
::abc.bat
::
::Batch file to evaluate if a given string can be represented with a set of
::20 2-faced blocks.
::
::Check if a string was provided
if "%1"=="" goto ERROR
::Define blocks. Separate blocks by ':', and terminat with '::'
set "FACES=BO:XK:DQ:CP:NA:GT:RE:TG:QD:FS:JW:HU:VI:AN:OB:ER:FS:LY:PC:ZM::"
set INPUT=%1
set "COUNTER=0"
::The main loop steps through the input string, checking if an available
::block exists for each character
:LOOP_MAIN
::Get character, increase counter, and test if there are still characters
call set "char=%%INPUT:~%COUNTER%,1%%"
set /a "COUNTER+=1"
if "%CHAR%"=="" goto LOOP_MAIN_END
set "OFFSET=0"
:LOOP_2
::Read in two characters (one block)
call set "BLOCK=%%FACES%:~%OFFSET%,2%%"
::Test if the all blocks were checked. If so, no match was found
if "%BLOCK%"==":" goto FAIL
::Test if current input string character is in the current block
if /i "%BLOCK:~0,1%"=="%CHAR%" goto FOUND
if /i "%BLOCK:~1,1%"=="%CHAR%" goto FOUND
::Increase offset to point to the next block
set /a "OFFSET+=3"
goto LOOP_2
:LOOP_2_END
::If found, blank out the block used
:FOUND
call set "FACES=%%FACES:%BLOCK%:= :%%"
goto LOOP_MAIN
:LOOP_MAIN_END
echo %0: It is possible to write the '%INPUT%' with my blocks.
goto END
:FAIL
echo %0: It is NOT possible to write the '%INPUT%' with my blocks.
goto END
:ERROR
echo %0: Please enter a string to evaluate
echo.
:END

48
Task/ABC-Problem/Bracmat/abc-problem.bracmat Normal file
View file

@ -0,0 +1,48 @@
(
( can-make-word
= ABC blocks
. (B O)
+ (X K)
+ (D Q)
+ (C P)
+ (N A)
+ (G T)
+ (R E)
+ (T G)
+ (Q D)
+ (F S)
+ (J W)
+ (H U)
+ (V I)
+ (A N)
+ (O B)
+ (E R)
+ (F S)
+ (L Y)
+ (P C)
+ (Z M)
: ?blocks
& ( ABC
= letter blocks A Z
. !arg:(.?)
| !arg:(@(?:%?letter ?arg).?blocks)
& !blocks
: ?
+ ?*(? !letter ?:?block)
+ (?&ABC$(!arg.!blocks+-1*!block))
)
& out
$ ( !arg
( ABC$(upp$!arg.!blocks)&yes
| no
)
)
)
& can-make-word'A
& can-make-word'BARK
& can-make-word'BOOK
& can-make-word'TREAT
& can-make-word'COMMON
& can-make-word'SQUAD
& can-make-word'CONFUSE
);

37
Task/ABC-Problem/C++/abc-problem.cpp Normal file
View file

@ -0,0 +1,37 @@
#include <iostream>
#include <vector>
#include <string>
#include <set>
#include <cctype>
typedef std::pair<char,char> item_t;
typedef std::vector<item_t> list_t;
bool can_make_word(const std::string& w, const list_t& vals) {
std::set<uint32_t> used;
while (used.size() < w.size()) {
const char c = toupper(w[used.size()]);
uint32_t x = used.size();
for (uint32_t i = 0, ii = vals.size(); i < ii; ++i) {
if (used.find(i) == used.end()) {
if (toupper(vals[i].first) == c || toupper(vals[i].second) == c) {
used.insert(i);
break;
}
}
}
if (x == used.size()) break;
}
return used.size() == w.size();
}
int main() {
list_t vals{ {'B','O'}, {'X','K'}, {'D','Q'}, {'C','P'}, {'N','A'}, {'G','T'}, {'R','E'}, {'T','G'}, {'Q','D'}, {'F','S'}, {'J','W'}, {'H','U'}, {'V','I'}, {'A','N'}, {'O','B'}, {'E','R'}, {'F','S'}, {'L','Y'}, {'P','C'}, {'Z','M'} };
std::vector<std::string> words{"A","BARK","BOOK","TREAT","COMMON","SQUAD","CONFUSE"};
for (const std::string& w : words) {
std::cout << w << ": " << std::boolalpha << can_make_word(w,vals) << ".\n";
}
}

82
Task/ABC-Problem/C-sharp/abc-problem.cs Normal file
View file

@ -0,0 +1,82 @@
using System.Collections.Generic;
using System.Linq;
void Main()
{
List<string> blocks =
new List<string>() { "bo", "xk", "dq", "cp", "na", "gt", "re", "tg", "qd", "fs",
"jw", "hu", "vi", "an", "ob", "er", "fs", "ly", "pc", "zm" };
List<string> words = new List<string>() {
"A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"};
var solver = new ABC(blocks);
foreach( var word in words)
{
Console.WriteLine("{0} :{1}", word, solver.CanMake(word));
}
}
class ABC
{
readonly Dictionary<char, List<int>> _blockDict = new Dictionary<char, List<int>>();
bool[] _used;
int _nextBlock;
readonly List<string> _blocks;
private void AddBlockChar(char c)
{
if (!_blockDict.ContainsKey(c))
{
_blockDict[c] = new List<int>();
}
_blockDict[c].Add(_nextBlock);
}
private void AddBlock(string block)
{
AddBlockChar(block[0]);
AddBlockChar(block[1]);
_nextBlock++;
}
public ABC(List<string> blocks)
{
_blocks = blocks;
foreach (var block in blocks)
{
AddBlock(block);
}
}
public bool CanMake(string word)
{
word = word.ToLower();
if (word.Length > _blockDict.Count)
{
return false;
}
_used = new bool[_blocks.Count];
return TryMake(word);
}
public bool TryMake(string word)
{
if (word == string.Empty)
{
return true;
}
var blocks = _blockDict[word[0]].Where(b => !_used[b]);
foreach (var block in blocks)
{
_used[block] = true;
if (TryMake(word.Substring(1)))
{
return true;
}
_used[block] = false;
}
return false;
}
}

41
Task/ABC-Problem/C/abc-problem.c Normal file
View file

@ -0,0 +1,41 @@
#include <stdio.h>
#include <ctype.h>
int can_make_words(char **b, char *word)
{
int i, ret = 0, c = toupper(*word);
#define SWAP(a, b) if (a != b) { char * tmp = a; a = b; b = tmp; }
if (!c) return 1;
if (!b[0]) return 0;
for (i = 0; b[i] && !ret; i++) {
if (b[i][0] != c && b[i][1] != c) continue;
SWAP(b[i], b[0]);
ret = can_make_words(b + 1, word + 1);
SWAP(b[i], b[0]);
}
return ret;
}
int main(void)
{
char* blocks[] = {
"BO", "XK", "DQ", "CP", "NA",
"GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB",
"ER", "FS", "LY", "PC", "ZM",
0 };
char *words[] = {
"", "A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "Confuse", 0
};
char **w;
for (w = words; *w; w++)
printf("%s\t%d\n", *w, can_make_words(blocks, *w));
return 0;
}

21
Task/ABC-Problem/Clojure/abc-problem.clj Normal file
View file

@ -0,0 +1,21 @@
(def blocks
(-> "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM" (.split " ") vec))
(defn omit
"return bs with (one instance of) b omitted"
[bs b]
(let [[before after] (split-with #(not= b %) bs)]
(concat before (rest after))))
(defn abc
"return lazy sequence of solutions (i.e. block lists)"
[blocks [c & cs]]
(if-some c
(for [b blocks :when (some #(= c %) b)
bs (abc (omit blocks b) cs)]
(cons b bs))
[[]]))
(doseq [word ["A" "BARK" "Book" "treat" "COMMON" "SQUAD" "CONFUSE"]]
(->> word .toUpperCase (abc blocks) first (printf "%s: %b\n" word)))

15
Task/ABC-Problem/CoffeeScript/abc-problem.coffee Normal file
View file

@ -0,0 +1,15 @@
canMakeWord = (word="") ->
# Create a shallow clone of the master blockList
blocks = blockList.slice 0
# Check if blocks contains letter
checkBlocks = (letter) ->
# Loop through every remaining block
for block, idx in blocks
# If letter is in block, blocks.splice will return an array, which will evaluate as true
return blocks.splice idx, 1 if letter.toUpperCase() in block
return false
# Return true if there are no falsy values
return false not in (checkBlocks letter for letter in word)
# Expect true, true, false, true, false, true, true, true
console.log (canMakeWord word for word in ["A", "BARK", "BOOK", "TREAT", "COMMON", "squad", "CONFUSE", "STORM"])

14
Task/ABC-Problem/Common-Lisp/abc-problem.lisp Normal file
View file

@ -0,0 +1,14 @@
(defun word-possible-p (word blocks)
(cond
((= (length word) 0) t)
((null blocks) nil)
(t (let*
((c (aref word 0))
(bs (remove-if-not #'(lambda (b)
(find c b :test #'char-equal))
blocks)))
(some #'identity
(loop for b in bs
collect (word-possible-p
(subseq word 1)
(remove b blocks))))))))

22
Task/ABC-Problem/D/abc-problem-1.d Normal file
View file

@ -0,0 +1,22 @@
import std.stdio, std.algorithm, std.string;
bool canMakeWord(in string word, in string[] blocks) pure /*nothrow*/ @safe {
auto bs = blocks.dup;
outer: foreach (immutable ch; word.toUpper) {
foreach (immutable block; bs)
if (block.canFind(ch)) {
bs = bs.remove(bs.countUntil(block));
continue outer;
}
return false;
}
return true;
}
void main() @safe {
immutable blocks = "BO XK DQ CP NA GT RE TG QD FS JW HU VI
AN OB ER FS LY PC ZM".split;
foreach (word; "" ~ "A BARK BoOK TrEAT COmMoN SQUAD conFUsE".split)
writefln(`"%s" %s`, word, canMakeWord(word, blocks));
}

39
Task/ABC-Problem/D/abc-problem-2.d Normal file
View file

@ -0,0 +1,39 @@
import std.ascii, core.stdc.stdlib;
bool canMakeWord(in string word, in string[] blocks) nothrow @nogc
in {
foreach (immutable char ch; word)
assert(ch.isASCII);
foreach (const block; blocks)
assert(block.length == 2 && block[0].isASCII && block[1].isASCII);
} body {
auto ptr = cast(string*)alloca(blocks.length * string.sizeof);
if (ptr == null)
exit(1);
auto blocks2 = ptr[0 .. blocks.length];
blocks2[] = blocks[];
outer: foreach (immutable i; 0 .. word.length) {
immutable ch = word[i].toUpper;
foreach (immutable j; 0 .. blocks2.length) {
if (blocks2[j][0] == ch || blocks2[j][1] == ch) {
if (blocks2.length > 1)
blocks2[j] = blocks2[$ - 1];
blocks2 = blocks2[0 .. $ - 1];
continue outer;
}
}
return false;
}
return true;
}
void main() {
import std.stdio, std.string;
immutable blocks = "BO XK DQ CP NA GT RE TG QD FS JW HU VI
AN OB ER FS LY PC ZM".split;
foreach (word; "" ~ "A BARK BoOK TrEAT COmMoN SQUAD conFUsE".split)
writefln(`"%s" %s`, word, canMakeWord(word, blocks));
}

38
Task/ABC-Problem/D/abc-problem-3.d Normal file
View file

@ -0,0 +1,38 @@
import std.stdio, std.ascii, std.algorithm, std.array;
alias Block = char[2];
// Modifies the order of the given blocks.
bool canMakeWord(Block[] blocks, in string word) pure nothrow
in {
assert(blocks.all!(w => w[].all!isAlpha));
assert(word.all!isAlpha);
} body {
if (word.empty)
return true;
immutable c = word[0].toUpper;
foreach (ref b; blocks) {
if (b[0].toUpper != c && b[1].toUpper != c)
continue;
blocks[0].swap(b);
if (blocks[1 .. $].canMakeWord(word[1 .. $]))
return true;
blocks[0].swap(b);
}
return false;
}
void main() {
enum Block[] blocks = "BO XK DQ CP NA GT RE TG QD FS
JW HU VI AN OB ER FS LY PC ZM".split;
foreach (w; "" ~ "A BARK BoOK TrEAT COmMoN SQUAD conFUsE".split)
writefln(`"%s" %s`, w, blocks.canMakeWord(w));
// Extra test.
Block[] blocks2 = ["AB", "AB", "AC", "AC"];
immutable word = "abba";
writefln(`"%s" %s`, word, blocks2.canMakeWord(word));
}

42
Task/ABC-Problem/D/abc-problem-4.d Normal file
View file

@ -0,0 +1,42 @@
import std.stdio, std.ascii, std.algorithm, std.array, std.range;
alias Block = char[2];
bool canMakeWord(immutable Block[] blocks, in string word) pure nothrow
in {
assert(blocks.all!(w => w[].all!isAlpha));
assert(word.all!isAlpha);
} body {
bool inner(size_t[] indexes, in string w) pure nothrow {
if (w.empty)
return true;
immutable c = w[0].toUpper;
foreach (ref idx; indexes) {
if (blocks[idx][0].toUpper != c &&
blocks[idx][1].toUpper != c)
continue;
indexes[0].swap(idx);
if (inner(indexes[1 .. $], w[1 .. $]))
return true;
indexes[0].swap(idx);
}
return false;
}
return inner(blocks.length.iota.array, word);
}
void main() {
enum Block[] blocks = "BO XK DQ CP NA GT RE TG QD FS
JW HU VI AN OB ER FS LY PC ZM".split;
foreach (w; "" ~ "A BARK BoOK TrEAT COmMoN SQUAD conFUsE".split)
writefln(`"%s" %s`, w, blocks.canMakeWord(w));
// Extra test.
immutable Block[] blocks2 = ["AB", "AB", "AC", "AC"];
immutable word = "abba";
writefln(`"%s" %s`, word, blocks2.canMakeWord(word));
}

63
Task/ABC-Problem/Delphi/abc-problem.delphi Normal file
View file

@ -0,0 +1,63 @@
program ABC;
{$APPTYPE CONSOLE}
uses SysUtils;
type
TBlock = set of char;
const
TheBlocks : array [0..19] of TBlock =
(
[ 'B', 'O' ], [ 'X', 'K' ], [ 'D', 'Q' ], [ 'C', 'P' ], [ 'N', 'A' ],
[ 'G', 'T' ], [ 'R', 'E' ], [ 'T', 'G' ], [ 'Q', 'D' ], [ 'F', 'S' ],
[ 'J', 'W' ], [ 'H', 'U' ], [ 'V', 'I' ], [ 'A', 'N' ], [ 'O', 'B' ],
[ 'E', 'R' ], [ 'F', 'S' ], [ 'L', 'Y' ], [ 'P', 'C' ], [ 'Z', 'M' ]
);
function SolveABC(Target : string; Blocks : array of TBlock) : boolean;
var
iChr : integer;
Used : array [0..19] of boolean;
function FindUnused(TargetChr : char) : boolean; // Nested routine
var
iBlock : integer;
begin
Result := FALSE;
for iBlock := low(Blocks) to high(Blocks) do
if (not Used[iBlock]) and ( TargetChr in Blocks[iBlock] ) then
begin
Result := TRUE;
Used[iBlock] := TRUE;
Break;
end;
end;
begin
FillChar(Used, sizeof(Used), ord(FALSE));
Result := TRUE;
iChr := 1;
while Result and (iChr <= length(Target)) do
if FindUnused(Target[iChr]) then inc(iChr)
else Result := FALSE;
end;
procedure CheckABC(Target : string);
begin
if SolveABC(uppercase(Target), TheBlocks) then
writeln('Can make ' + Target)
else
writeln('Can NOT make ' + Target);
end;
begin
CheckABC('A');
CheckABC('BARK');
CheckABC('BOOK');
CheckABC('TREAT');
CheckABC('COMMON');
CheckABC('SQUAD');
CheckABC('CONFUSE');
readln;
end.

16
Task/ABC-Problem/Erlang/abc-problem.erl Normal file
View file

@ -0,0 +1,16 @@
-module(abc).
-export([can_make_word/1, can_make_word/2, blocks/0]).
blocks() -> ["BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"].
can_make_word(Word) -> can_make_word(Word, blocks()).
can_make_word(Word, Avail) -> can_make_word(string:to_upper(Word), Avail, []).
can_make_word([], _, _) -> true;
can_make_word(_, [], _) -> false;
can_make_word([L|Tail], [B|Rest], Tried) ->
(lists:member(L,B) andalso can_make_word(Tail, lists:append(Rest, Tried),[]))
orelse can_make_word([L|Tail], Rest, [B|Tried]).
main(_) -> lists:map(fun(W) -> io:fwrite("~s: ~s~n", [W, can_make_word(W)]) end,
["A","Bark","Book","Treat","Common","Squad","Confuse"]).

35
Task/ABC-Problem/Euphoria/abc-problem.euphoria Normal file
View file

@ -0,0 +1,35 @@
include std/text.e
sequence blocks = {{'B','O'},{'X','K'},{'D','Q'},{'C','P'},{'N','A'},
{'G','T'},{'R','E'},{'T','G'},{'Q','D'},{'F','S'},
{'J','W'},{'H','U'},{'V','I'},{'A','N'},{'O','B'},
{'E','R'},{'F','S'},{'L','Y'},{'P','C'},{'Z','M'}}
sequence words = {"A","BarK","BOOK","TrEaT","COMMON","SQUAD","CONFUSE"}
sequence current_word
sequence temp
integer matches
for i = 1 to length(words) do
current_word = upper(words[i])
temp = blocks
matches = 0
for j = 1 to length(current_word) do
for k = 1 to length(temp) do
if find(current_word[j],temp[k]) then
temp = remove(temp,k)
matches += 1
exit
end if
end for
if length(current_word) = matches then
printf(1,"%s: TRUE\n",{words[i]})
exit
end if
end for
if length(current_word) != matches then
printf(1,"%s: FALSE\n",{words[i]})
end if
end for
if getc(0) then end if

44
Task/ABC-Problem/FBSL/abc-problem.fbsl Normal file
View file

@ -0,0 +1,44 @@
#APPTYPE CONSOLE
SUB MAIN()
BlockCheck("A")
BlockCheck("BARK")
BlockCheck("BooK")
BlockCheck("TrEaT")
BlockCheck("comMON")
BlockCheck("sQuAd")
BlockCheck("Confuse")
pause
END SUB
FUNCTION BlockCheck(str)
print str " " iif( Blockable( str ), "can", "cannot" ) " be spelled with blocks."
END FUNCTION
FUNCTION Blockable(str AS STRING)
DIM blocks AS STRING = "BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"
DIM C AS STRING = ""
DIM POS AS INTEGER = 0
FOR DIM I = 1 TO LEN(str)
C = str{i}
POS = INSTR(BLOCKS, C, 0, 1) 'case insensitive
IF POS > 0 THEN
'if the pos is odd, it's the first of the pair
IF POS MOD 2 = 1 THEN
'so clear the first and the second
poke(@blocks + pos - 1," ")
poke(@blocks + pos," ")
'otherwise, it's the last of the pair
ELSE
'clear the second and the first
poke(@blocks + pos - 1," ")
poke(@blocks + pos - 2," ")
END IF
ELSE
'not found, so can't be spelled
RETURN FALSE
END IF
NEXT
'got thru to here, so can be spelled
RETURN TRUE
END FUNCTION

70
Task/ABC-Problem/Fortran/abc-problem.f Normal file
View file

@ -0,0 +1,70 @@
!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Thu Jun 5 01:52:03
!
!make f && for a in '' a bark book treat common squad confuse ; do echo $a | ./f ; done
!gfortran -std=f2008 -Wall -fopenmp -ffree-form -fall-intrinsics -fimplicit-none -g f.f08 -o f
! T
! T A NA
! T BARK BO NA RE XK
! F BOOK OB BO -- --
! T TREAT GT RE ER NA TG
! F COMMON PC OB ZM -- -- --
! T SQUAD FS DQ HU NA QD
! T CONFUSE CP BO NA FS HU FS RE
!
!Compilation finished at Thu Jun 5 01:52:03
program abc
implicit none
integer, parameter :: nblocks = 20
character(len=nblocks) :: goal
integer, dimension(nblocks) :: solution
character(len=2), dimension(0:nblocks) :: blocks_copy, blocks = &
&(/'--','BO','XK','DQ','CP','NA','GT','RE','TG','QD','FS','JW','HU','VI','AN','OB','ER','FS','LY','PC','ZM'/)
logical :: valid
integer :: i, iostat
read(5,*,iostat=iostat) goal
if (iostat .ne. 0) goal = ''
call ucase(goal)
solution = 0
blocks_copy = blocks
valid = assign_block(goal(1:len_trim(goal)), blocks, solution, 1)
write(6,*) valid, ' '//goal, (' '//blocks_copy(solution(i)), i=1,len_trim(goal))
contains
recursive function assign_block(goal, blocks, solution, n) result(valid)
implicit none
logical :: valid
character(len=*), intent(in) :: goal
character(len=2), dimension(0:), intent(inout) :: blocks
integer, dimension(:), intent(out) :: solution
integer, intent(in) :: n
integer :: i
character(len=2) :: backing_store
valid = .true.
if (len(goal)+1 .eq. n) return
do i=1, size(blocks)
if (index(blocks(i),goal(n:n)) .ne. 0) then
backing_store = blocks(i)
blocks(i) = ''
solution(n) = i
if (assign_block(goal, blocks, solution, n+1)) return
blocks(i) = backing_store
end if
end do
valid = .false.
return
end function assign_block
subroutine ucase(a)
implicit none
character(len=*), intent(inout) :: a
integer :: i, j
do i = 1, len_trim(a)
j = index('abcdefghijklmnopqrstuvwxyz',a(i:i))
if (j .ne. 0) a(i:i) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'(j:j)
end do
end subroutine ucase
end program abc

39
Task/ABC-Problem/Go/abc-problem.go Normal file
View file

@ -0,0 +1,39 @@
package main
import (
"fmt"
"strings"
)
func newSpeller(blocks string) func(string) bool {
bl := strings.Fields(blocks)
return func(word string) bool {
return r(word, bl)
}
}
func r(word string, bl []string) bool {
if word == "" {
return true
}
c := word[0] | 32
for i, b := range bl {
if c == b[0]|32 || c == b[1]|32 {
bl[i], bl[0] = bl[0], b
if r(word[1:], bl[1:]) == true {
return true
}
bl[i], bl[0] = bl[0], bl[i]
}
}
return false
}
func main() {
sp := newSpeller(
"BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM")
for _, word := range []string{
"A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"} {
fmt.Println(word, sp(word))
}
}

12
Task/ABC-Problem/Groovy/abc-problem-1.groovy Normal file
View file

@ -0,0 +1,12 @@
class ABCSolver {
def blocks
ABCSolver(blocks = []) { this.blocks = blocks }
boolean canMakeWord(rawWord) {
if (rawWord == '' || rawWord == null) { return true; }
def word = rawWord.toUpperCase()
def blocksLeft = [] + blocks
word.every { letter -> blocksLeft.remove(blocksLeft.find { block -> block.contains(letter) }) }
}
}

6
Task/ABC-Problem/Groovy/abc-problem-2.groovy Normal file
View file

@ -0,0 +1,6 @@
def a = new ABCSolver(["BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"])
['', 'A', 'BARK', 'book', 'treat', 'COMMON', 'SQuAd', 'CONFUSE'].each {
println "'${it}': ${a.canMakeWord(it)}"
}

15
Task/ABC-Problem/Haskell/abc-problem.hs Normal file
View file

@ -0,0 +1,15 @@
import Data.List (delete)
import Data.Char (toUpper)
-- returns list of all solutions, each solution being a list of blocks
abc :: (Eq a) => [[a]] -> [a] -> [[[a]]]
abc _ [] = [[]]
abc blocks (c:cs) = [b:ans | b <- blocks, c `elem` b,
ans <- abc (delete b blocks) cs]
blocks = ["BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"]
main :: IO ()
main = mapM_ (\w -> print (w, not . null $ abc blocks (map toUpper w)))
["", "A", "BARK", "BoOK", "TrEAT", "COmMoN", "SQUAD", "conFUsE"]

24
Task/ABC-Problem/Icon/abc-problem.icon Normal file
View file

@ -0,0 +1,24 @@
procedure main(A)
blocks := ["bo","xk","dq","cp","na","gt","re","tg","qd","fs",
"jw","hu","vi","an","ob","er","fs","ly","pc","zm",&null]
every write("\"",word := !A,"\" ",checkSpell(map(word),blocks)," with blocks.")
end
procedure checkSpell(w,blocks)
blks := copy(blocks)
w ? return if canMakeWord(blks) then "can be spelled"
else "can not be spelled"
end
procedure canMakeWord(blks)
c := move(1) | return
if /blks[1] then fail
every i := 1 to *blks do {
if /blks[i] then (move(-1),fail)
if c == !blks[i] then {
blks[1] :=: blks[i]
if canMakeWord(blks[2:0]) then return
blks[1] :=: blks[i]
}
}
end

11
Task/ABC-Problem/J/abc-problem-1.j Normal file
View file

@ -0,0 +1,11 @@
reduce=: verb define
'rows cols'=. i.&.> $y
for_c. cols do.
r=. 1 i.~ c {"1 y NB. row idx of first 1 in col
if. r = #rows do. continue. end.
y=. 0 (<((r+1)}.rows);c) } y NB. zero rest of col
y=. 0 (<(r;(c+1)}.cols)) } y NB. zero rest of row
end.
)
abc=: *./@(+./)@reduce@(e."1~ ,)&toupper :: 0:

14
Task/ABC-Problem/J/abc-problem-2.j Normal file
View file

@ -0,0 +1,14 @@
Blocks=: ];._2 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM '
ExampleWords=: <;._2 'A BaRK BOoK tREaT COmMOn SqUAD CoNfuSE '
Blocks&abc &> ExampleWords
1 1 0 1 0 1 1
require 'format/printf'
'%10s %s' printf (dquote ; 'FT' {~ Blocks&abc) &> ExampleWords
"A" T
"BaRK" T
"BOoK" F
"tREaT" T
"COmMOn" F
"SqUAD" T
"CoNfuSE" T

3
Task/ABC-Problem/J/abc-problem-3.j Normal file
View file

@ -0,0 +1,3 @@
delElem=: {~<@<@<
uppc=:(-32*96&<*.123&>)&.(3&u:)
reduc=: ] delElem 1 i.~e."0 1

10
Task/ABC-Problem/J/abc-problem-4.j Normal file
View file

@ -0,0 +1,10 @@
Blocks=: >;:'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM '
ExampleWords=: ;: 'A BaRK BOoK tREaT COmMOn SqUAD CoNfuSE '
canform=:4 :0
word=: toupper y
need=: #/.~ word,word
relevant=: (x +./@e."1 word) # x
candidates=: word,"1>,{{relevant
+./(((#need){. #/.~)"1 candidates) */ .>:need
)

14
Task/ABC-Problem/J/abc-problem-5.j Normal file
View file

@ -0,0 +1,14 @@
Blocks canform 0{::ExampleWords
1
Blocks canform 1{::ExampleWords
1
Blocks canform 2{::ExampleWords
0
Blocks canform 3{::ExampleWords
1
Blocks canform 4{::ExampleWords
0
Blocks canform 5{::ExampleWords
1
Blocks canform 6{::ExampleWords
1

44
Task/ABC-Problem/Java/abc-problem.java Normal file
View file

@ -0,0 +1,44 @@
import java.util.Arrays;
public class ABC{
private static void swap(int i, int j, Object... arr){
Object tmp = arr[i];
arr[i] = arr[j];
arr[j] = tmp;
}
public static boolean canMakeWord(String word, String... blocks) {
if(word.length() == 0)
return true;
char c = Character.toUpperCase(word.charAt(0));
for(int i = 0; i < blocks.length; i++) {
String b = blocks[i];
if(Character.toUpperCase(b.charAt(0)) != c && Character.toUpperCase(b.charAt(1)) != c)
continue;
swap(0, i, blocks);
if(canMakeWord(word.substring(1), Arrays.copyOfRange(blocks, 1, blocks.length)))
return true;
swap(0, i, blocks);
}
return false;
}
public static void main(String[] args){
String[] blocks = {"BO", "XK", "DQ", "CP", "NA",
"GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB",
"ER", "FS", "LY", "PC", "ZM"};
System.out.println("\"\": " + canMakeWord("", blocks));
System.out.println("A: " + canMakeWord("A", blocks));
System.out.println("BARK: " + canMakeWord("BARK", blocks));
System.out.println("book: " + canMakeWord("book", blocks));
System.out.println("treat: " + canMakeWord("treat", blocks));
System.out.println("COMMON: " + canMakeWord("COMMON", blocks));
System.out.println("SQuAd: " + canMakeWord("SQuAd", blocks));
System.out.println("CONFUSE: " + canMakeWord("CONFUSE", blocks));
}
}

32
Task/ABC-Problem/JavaScript/abc-problem.js Normal file
View file

@ -0,0 +1,32 @@
let characters = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM";
let blocks = characters.split(" ").map(pair => pair.split(""));
function isWordPossible(word) {
var letters = [...word.toUpperCase()];
var length = letters.length;
var copy = new Set(blocks);
for (let letter of letters) {
for (let block of copy) {
let index = block.indexOf(letter);
if (index !== -1) {
length--;
copy.delete(block);
break;
}
}
}
return !length;
}
[
"A",
"BARK",
"BOOK",
"TREAT",
"COMMON",
"SQUAD",
"CONFUSE"
].forEach(word => console.log(`${word}: ${isWordPossible(word)}`));

9
Task/ABC-Problem/Julia/abc-problem.julia Normal file
View file

@ -0,0 +1,9 @@
function abc (str, list)
isempty(str) && return true
for i = 1:length(list)
str[end] in list[i] &&
any([abc(str[1:end-1], deleteat!(copy(list), i))]) &&
return true
end
false
end

21
Task/ABC-Problem/Logo/abc-problem.logo Normal file
View file

@ -0,0 +1,21 @@
make "blocks [[B O] [X K] [D Q] [C P] [N A] [G T] [R E] [T G] [Q D] [F S]
[J W] [H U] [V I] [A N] [O B] [E R] [F S] [L Y] [P C] [Z M]]
to can_make? :word [:avail :blocks]
if empty? :word [output "true]
local "letter make "letter first :word
foreach :avail [
local "i make "i #
local "block make "block ?
if member? :letter :block [
if (can_make? bf :word filter [notequal? # :i] :avail) [output "true]
]
]
output "false
end
foreach [A BARK BOOK TREAT COMMON SQUAD CONFUSE] [
print sentence word ? ": can_make? ?
]
bye

26
Task/ABC-Problem/MATLAB/abc-problem.m Normal file
View file

@ -0,0 +1,26 @@
function testABC
combos = ['BO' ; 'XK' ; 'DQ' ; 'CP' ; 'NA' ; 'GT' ; 'RE' ; 'TG' ; 'QD' ; ...
'FS' ; 'JW' ; 'HU' ; 'VI' ; 'AN' ; 'OB' ; 'ER' ; 'FS' ; 'LY' ; ...
'PC' ; 'ZM'];
words = {'A' 'BARK' 'BOOK' 'TREAT' 'COMMON' 'SQUAD' 'CONFUSE'};
for k = 1:length(words)
possible = canMakeWord(words{k}, combos);
fprintf('Can%s make word %s.\n', char(~possible.*'NOT'), words{k})
end
end
function isPossible = canMakeWord(word, combos)
word = lower(word);
combos = lower(combos);
isPossible = true;
k = 1;
while isPossible && k <= length(word)
[r, c] = find(combos == word(k), 1);
if ~isempty(r)
combos(r, :) = '';
else
isPossible = false;
end
k = k+1;
end
end

98
Task/ABC-Problem/MAXScript/abc-problem-1.max Normal file
View file

@ -0,0 +1,98 @@
-- This is the blocks array
global GlobalBlocks = #("BO","XK","DQ","CP","NA", \
"GT","RE","TG","QD","FS", \
"JW","HU","VI","AN","OB", \
"ER","FS","LY","PC","ZM")
-- This function returns true if "_str" is part of "_word", false otherwise
fn occurs _str _word =
(
if _str != undefined and _word != undefined then
(
matchpattern _word pattern:("*"+_str+"*")
) else return false
)
-- This is the main function
fn isWordPossible word blocks: = -- blocks is a keyword argument
(
word = toupper word -- convert the string to upper case, to make it case insensitive
if blocks == unsupplied do blocks = GlobalBlocks
-- if blocks (keyword argument) is unsupplied, use the global blocks array (this is for recursion)
blocks = deepcopy blocks
local pos = 1 -- start at the beginning of the word
local solvedLetters = #() -- this array stores the indices of solved letters
while pos <= word.count do -- loop through every character in the word
(
local possibleBlocks = #() -- this array stores the blocks which can be used to make that letter
for b = 1 to Blocks.count do -- this loop finds all the possible blocks that can be used to make that letter
(
if occurs word[pos] blocks[b] do
(
appendifunique possibleBlocks b
)
)
if possibleBlocks.count > 0 then -- if it found any blocks
(
if possibleBlocks.count == 1 then -- if it found one block, then continue
(
appendifunique solvedLetters pos
deleteitem blocks possibleblocks[1]
pos += 1
)
else -- if it found more than one
(
for b = 1 to possibleBlocks.count do -- loop through every possible block
(
local possibleBlock = blocks[possibleBlocks[b]]
local blockFirstLetter = possibleBlock[1]
local blockSecondLetter = possibleBlock[2]
local matchingLetter = if blockFirstLetter == word[pos] then 1 else 2
-- ^ this is the index of the matching letter on the block
local notMatchingIndex = if matchingLetter == 1 then 2 else 1
local notMatchingLetter = possibleBlock[notMatchingIndex]
-- ^ this is the other letter on the block
if occurs notMatchingLetter (substring word (pos+1) -1) then
( -- if the other letter occurs in the rest of the word
local removedBlocks = deepcopy blocks -- copy the current blocks array
deleteitem removedBlocks possibleBlocks[b] -- remove the item from the copied array
-- recursively check if the word is possible if that block is taken away from the array:
if (isWordPossible (substring word (pos+1) -1) blocks:removedBlocks) then
( -- if it is, then remove the block and move to next character
appendifunique solvedLetters pos
deleteitem blocks possibleblocks[1]
pos += 1
exit
)
else
( -- if it isn't and it looped through every possible block, then the word is not possible
if b == possibleBlocks.count do return false
)
)
else
( -- if the other letter on this block doesn't occur in the rest of the word, then the letter is solved, continue
appendifunique solvedLetters pos
deleteitem blocks possibleblocks[b]
pos += 1
exit
)
)
)
) else return false -- if it didn't find any blocks, then return false
)
makeuniquearray solvedLetters -- make sure there are no duplicates in the solved array
if solvedLetters.count != word.count then return false -- if number of solved letters is not equal to word length
else
( -- this checks if all the solved letters are the same as the word
check = ""
for bit in solvedLetters do append check word[bit]
if check == word then return true else return false
)
)

14
Task/ABC-Problem/MAXScript/abc-problem-2.max Normal file
View file

@ -0,0 +1,14 @@
iswordpossible "a"
true
iswordpossible "bark"
true
iswordpossible "book"
false
iswordpossible "treat"
true
iswordpossible "common"
false
iswordpossible "squad"
true
iswordpossible "confuse"
true

30
Task/ABC-Problem/MAXScript/abc-problem-3.max Normal file
View file

@ -0,0 +1,30 @@
fn isWordPossible2 word =
(
Blocks = #("BO","XK","DQ","CP","NA", \
"GT","RE","TG","QD","FS", \
"JW","HU","VI","AN","OB", \
"ER","FS","LY","PC","ZM")
word = toupper word
local pos = 1
local solvedLetters = #()
while pos <= word.count do
(
for i = 1 to blocks.count do
(
if (matchpattern blocks[i] pattern:("*"+word[pos]+"*")) then
(
deleteitem blocks i
appendifunique solvedLetters pos
pos +=1
exit
)
else if i == blocks.count do return false
)
)
if solvedLetters.count == word.count then
(
local check = ""
for bit in solvedLetters do append check word[bit]
if check == word then return true else return false
) else return false
)

4
Task/ABC-Problem/MAXScript/abc-problem-4.max Normal file
View file

@ -0,0 +1,4 @@
iswordpossible "water"
true
iswordpossible2 "water"
false

12
Task/ABC-Problem/Mathematica/abc-problem.math Normal file
View file

@ -0,0 +1,12 @@
blocks=Partition[Characters[ToLowerCase["BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"]],2];
ClearAll[DoStep,ABCBlockQ]
DoStep[chars_List,blcks_List,chosen_List]:=Module[{opts},
If[chars=!={},
opts=Select[blcks,MemberQ[#,First[chars]]&];
{Rest[chars],DeleteCases[blcks,#,1,1],Append[chosen,#]}&/@opts
,
{{chars,blcks,chosen}}
]
]
DoStep[opts_List]:=Flatten[DoStep@@@opts,1]
ABCBlockQ[str_String]:=(FixedPoint[DoStep,{{Characters[ToLowerCase[str]],blocks,{}}}]=!={})

40
Task/ABC-Problem/OCaml/abc-problem.ocaml Normal file
View file

@ -0,0 +1,40 @@
let blocks = [
('B', 'O'); ('X', 'K'); ('D', 'Q'); ('C', 'P');
('N', 'A'); ('G', 'T'); ('R', 'E'); ('T', 'G');
('Q', 'D'); ('F', 'S'); ('J', 'W'); ('H', 'U');
('V', 'I'); ('A', 'N'); ('O', 'B'); ('E', 'R');
('F', 'S'); ('L', 'Y'); ('P', 'C'); ('Z', 'M');
]
let find_letter blocks c =
let found, remaining =
List.partition (fun (c1, c2) -> c1 = c || c2 = c) blocks
in
match found with
| _ :: res -> Some (res @ remaining)
| _ -> None
let can_make_word w =
let n = String.length w in
let rec aux i _blocks =
if i >= n then true else
match find_letter _blocks w.[i] with
| None -> false
| Some rem_blocks ->
aux (succ i) rem_blocks
in
aux 0 blocks
let test label f (word, should) =
Printf.printf "- %s %S = %B (should: %B)\n" label word (f word) should
let () =
List.iter (test "can make word" can_make_word) [
"A", true;
"BARK", true;
"BOOK", false;
"TREAT", true;
"COMMON", false;
"SQUAD", true;
"CONFUSE", true;
]

83
Task/ABC-Problem/Oberon-2/abc-problem.oberon-2 Normal file
View file

@ -0,0 +1,83 @@
MODULE ABCBlocks;
IMPORT
Object,
Out;
VAR
blocks: ARRAY 20 OF STRING;
PROCEDURE CanMakeWord(w: STRING): BOOLEAN;
VAR
used: ARRAY 20 OF LONGINT;
wChars: Object.CharsLatin1;
i,j: LONGINT;
PROCEDURE IsUsed(i: LONGINT): BOOLEAN;
VAR
b: LONGINT;
BEGIN
b := 0;
WHILE (b < LEN(used) - 1) & (used[b] # -1) DO
IF used[b] = i THEN RETURN TRUE END;
INC(b)
END;
RETURN FALSE
END IsUsed;
PROCEDURE GetBlockFor(blocks: ARRAY OF STRING; c: CHAR): LONGINT;
VAR
i: LONGINT;
BEGIN
i := 0;
WHILE (i < LEN(blocks)) DO
IF (blocks[i].IndexOf(c,0) >= 0) & (~IsUsed(i)) THEN RETURN i END;
INC(i)
END;
RETURN -1;
END GetBlockFor;
BEGIN
FOR i := 0 TO LEN(used) - 1 DO used[i] := -1 END;
wChars := w(Object.String8).CharsLatin1();
i := 0;
WHILE (i < LEN(wChars^) - 1) DO
j := GetBlockFor(blocks,CAP(wChars[i]));
IF j < 0 THEN RETURN FALSE END;
used[i] := j;
INC(i)
END;
RETURN TRUE
END CanMakeWord;
BEGIN
blocks[0] := "BO";
blocks[1] := "XK";
blocks[2] := "DQ";
blocks[3] := "CP";
blocks[4] := "NA";
blocks[5] := "GT";
blocks[6] := "RE";
blocks[7] := "TG";
blocks[8] := "QD";
blocks[9] := "FS";
blocks[10] := "JW";
blocks[11] := "HU";
blocks[12] := "VI";
blocks[13] := "AN";
blocks[14] := "OB";
blocks[15] := "ER";
blocks[16] := "FS";
blocks[17] := "LY";
blocks[18] := "PC";
blocks[19] := "ZM";
Out.String("A: ");Out.Bool(CanMakeWord("A"));Out.Ln;
Out.String("BARK: ");Out.Bool(CanMakeWord("BARK"));Out.Ln;
Out.String("BOOK: ");Out.Bool(CanMakeWord("BOOK"));Out.Ln;
Out.String("TREAT: ");Out.Bool(CanMakeWord("TREAT"));Out.Ln;
Out.String("COMMON: ");Out.Bool(CanMakeWord("COMMON"));Out.Ln;
Out.String("SQAD: ");Out.Bool(CanMakeWord("SQUAD"));Out.Ln;
Out.String("confuse: ");Out.Bool(CanMakeWord("confuse"));Out.Ln;
END ABCBlocks.

29
Task/ABC-Problem/PHP/abc-problem.php Normal file
View file

@ -0,0 +1,29 @@
<?php
$words = array("A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "Confuse");
function canMakeWord($word) {
$word = strtoupper($word);
$blocks = array(
"BO", "XK", "DQ", "CP", "NA",
"GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB",
"ER", "FS", "LY", "PC", "ZM",
);
foreach (str_split($word) as $char) {
foreach ($blocks as $k => $block) {
if (strpos($block, $char) !== FALSE) {
unset($blocks[$k]);
continue(2);
}
}
return false;
}
return true;
}
foreach ($words as $word) {
echo $word.': ';
echo canMakeWord($word) ? "True" : "False";
echo "\r\n";
}

25
Task/ABC-Problem/PL-I/abc-problem-1.pli Normal file
View file

@ -0,0 +1,25 @@
ABC: procedure options (main); /* 12 January 2014 */
declare word character (20) varying, blocks character (200) varying initial
('((B O) (X K) (D Q) (C P) (N A) (G T) (R E) (T G) (Q D) (F S)
(J W) (H U) (V I) (A N) (O B) (E R) (F S) (L Y) (P C) (Z M))');
declare tblocks character (200) varying;
declare (true value ('1'b), false value ('0'b), flag) bit (1);
declare ch character (1);
declare (i, k) fixed binary;
do word = 'A', 'BARK', 'BOOK', 'TREAT', 'COMMON', 'SQuAd', 'CONFUSE';
flag = true;
tblocks = blocks;
do i = 1 to length(word);
ch = substr(word, i, 1);
k = index(tblocks, uppercase(ch));
if k = 0 then
flag = false;
else /* Found a block with the letter on it. */
substr(tblocks, k-1, 4) = ' '; /* Delete the block. */
end;
if flag then put skip list (word, 'true'); else put skip list (word, 'false');
end;
end ABC;

121
Task/ABC-Problem/PL-I/abc-problem-2.pli Normal file
View file

@ -0,0 +1,121 @@
*process source attributes xref or(!) options nest;
abc: Proc Options(main);
/* REXX --------------------------------------------------------------
* 10.01.2013 Walter Pachl counts the number of possible ways
* translated from Rexx version 2
*-------------------------------------------------------------------*/
Dcl (ADDR,HBOUND,INDEX,LEFT,LENGTH,MAX,SUBSTR,TRANSLATE) builtin;
Dcl sysprint Print;
Dcl (i,j,k,m,mm,wi,wj,wlen,ways,lw) Bin Fixed(15);
Dcl blocks(20) Char(2)
Init('BO','XK','DQ','CP','NA','GT','RE','TG','QD','FS','JW',
'HU','VI','AN','OB','ER','FS','LY','PC','ZM');
Dcl blk Char(2);
Dcl words(8) Char(7) Var
Init('$','A','baRk','bOOk','trEat','coMMon','squaD','conFuse');
Dcl word Char(7) Var;
Dcl c Char(1);
Dcl (show,cannot) Bit(1) Init('0'b);
Dcl poss(100,0:100) Pic'99'; poss=0;
Dcl s(20,100) char(100) Var;
Dcl str Char(100);
Dcl 1 *(30) Based(addr(str)),
2 strp Pic'99',
2 * Char(1);
Dcl ns(20) Bin Fixed(15) Init((20)0);
Dcl ol(100) Char(100) Var;
Dcl os Char(100) Var;
wlen=0;
Dcl lower Char(26) Init('abcdefghijklmnopqrstuvwxyz');
Dcl upper Char(26) Init('ABCDEFGHIJKLMNOPQRSTUVWXYZ');
Do wi=1 To hbound(words);
wlen=max(wlen,length(words(wi)));
End;
Do wi=1 To hbound(words);
word = translate(words(wi),upper,lower);
ways=0;
lw=length(word);
cannot='0'b;
poss=0;
ns=0;
ol='';
iloop:
Do i=1 To lw; /* loop over the characters */
c=substr(word,i,1); /* the current character */
Do j=1 To hbound(blocks); /* loop over blocks */
blk=blocks(j);
If index(blk,c)>0 Then Do; /* block can be used in this pos( */
poss(i,0)+=1; /* number of possible blocks for pos i */
poss(i,poss(i,0))=j;
End;
End;
If poss(i,0)=0 Then Do;
Leave iloop;
End;
End;
If i>lw Then Do; /* no prohibitive character */
ns=0;
Do j=1 To poss(1,0); /* build possible strings for char 1 */
ns(1)+=1;;
s(1,j)=poss(1,j);
End;
Do m=2 To lw; /* build possible strings for chars 1 to i */
mm=m-1;
Do j=1 To ns(mm);
Do k=1 To poss(m,0);
ns(m)+=1;
s(m,ns(m))=s(mm,j)!!' '!!poss(m,k);
End;
End;
End;
Do m=1 To ns(lw);
If valid(s(lw,m)) Then Do;
ways+=1;
str=s(lw,m);
Do k=1 To lw;
ol(ways)=ol(ways)!!blocks(strp(k))!!' ';
End;
End;
End;
End;
/*--------------------------------------------------------------------
* now show the result
*-------------------------------------------------------------------*/
os=left(''''!!word!!'''',wlen+2);
Select;
When(ways=0)
os=os!!' cannot be spelt.';
When(ways=1)
os=os!!' can be spelt.';
Otherwise
os=os!!' can be spelt in'!!ways!!' ways.';
End;
Put Skip List(os);
If show Then Do;
Do wj=1 To ways;
Put Edit(' '!!ol(wj))(Skip,a);
End;
End;
End;
Return;
valid: Procedure(list) Returns(bit(1));
/*--------------------------------------------------------------------
* Check if the same block is used more than once -> 0
* Else: the combination is valid
*-------------------------------------------------------------------*/
Dcl list Char(*) Var;
Dcl i Bin Fixed(15);
Dcl used(20) Bit(1);
str=list;
used='0'b;
Do i=1 To lw;
If used(strp(i)) Then
Return('0'b);
used(strp(i))='1'b;
End;
Return('1'b);
End;
End;

21
Task/ABC-Problem/Perl-6/abc-problem.pl6 Normal file
View file

@ -0,0 +1,21 @@
multi can-spell-word(Str $word, @blocks) {
my @regex = @blocks.map({ EVAL "/{.comb.join('|')}/" }).grep: { .ACCEPTS($word.uc) }
can-spell-word $word.uc.comb, @regex;
}
multi can-spell-word([$head,*@tail], @regex) {
for @regex -> $re {
if $head ~~ $re {
return True unless @tail;
return False if @regex == 1;
return True if can-spell-word @tail, @regex.grep: * !=== $re;
}
}
False;
}
my @b = <BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM>;
for <A BaRK BOoK tREaT COmMOn SqUAD CoNfuSE> {
say "$_ &can-spell-word($_, @b)";
}

26
Task/ABC-Problem/Perl/abc-problem-1.pl Normal file
View file

@ -0,0 +1,26 @@
#!/usr/bin/perl
use warnings;
use strict;
sub can_make_word {
my ($word, @blocks) = @_;
$_ = uc join q(), sort split // for @blocks;
my %blocks;
$blocks{$_}++ for @blocks;
return _can_make_word(uc $word, %blocks)
}
sub _can_make_word {
my ($word, %blocks) = @_;
my $char = substr $word, 0, 1, q();
my @candidates = grep 0 <= index($_, $char), keys %blocks;
for my $candidate (@candidates) {
next if $blocks{$candidate} <= 0;
local $blocks{$candidate} = $blocks{$candidate} - 1;
return 1 if q() eq $word or _can_make_word($word, %blocks);
}
return
}

13
Task/ABC-Problem/Perl/abc-problem-2.pl Normal file
View file

@ -0,0 +1,13 @@
use Test::More tests => 8;
my @blocks1 = qw(BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM);
is(can_make_word("A", @blocks1), 1);
is(can_make_word("BARK", @blocks1), 1);
is(can_make_word("BOOK", @blocks1), undef);
is(can_make_word("TREAT", @blocks1), 1);
is(can_make_word("COMMON", @blocks1), undef);
is(can_make_word("SQUAD", @blocks1), 1);
is(can_make_word("CONFUSE", @blocks1), 1);
my @blocks2 = qw(US TZ AO QA);
is(can_make_word('auto', @blocks2), 1);

33
Task/ABC-Problem/PicoLisp/abc-problem.l Normal file
View file

@ -0,0 +1,33 @@
(setq *Blocks
'((B O) (X K) (D Q) (C P) (N A) (G T) (R E)
(T G) (Q D) (F S) (J W) (H U) (V I) (A N)
(O B) (E R) (F S) (L Y) (P C) (Z M) ) )
(setq *Words '("" "1" "A" "BARK" "BOOK" "TREAT"
"Bbb" "COMMON" "SQUAD" "Confuse"
"abba" "ANBOCPDQERSFTGUVWXLZ") )
(de abc (W B)
(let Myblocks (copy B)
(fully
'((C)
(when (seek '((Lst) (member C (car Lst))) Myblocks)
(set @)
T ) )
(chop (uppc W)) ) ) )
(de abcR (W B)
(nond
((car W) T)
((car B) NIL)
(NIL
(setq W (chop W))
(let? I
(find
'((Lst) (member (uppc (car W)) Lst))
B )
(abcR (cdr W) (delete I B)) ) ) ) )
(for Word *Words
(println Word (abc Word *Blocks) (abcR Word *Blocks)) )
(bye)

155
Task/ABC-Problem/PowerBASIC/abc-problem.powerbasic Normal file
View file

@ -0,0 +1,155 @@
#COMPILE EXE
#DIM ALL
'
' A B C p r o b l e m . b a s
'
' by Geary Chopoff
' for Chopoff Consulting and RosettaCode.org
' on 2014Jul23
'
'2014Jul23
'
'You are given a collection of ABC blocks. Just like the ones you had when you were a kid.
'There are twenty blocks with two letters on each block. You are guaranteed to have a complete
'alphabet amongst all sides of the blocks. The sample blocks are:
'((B O) (X K) (D Q) (C P) (N A) (G T) (R E) (T G) (Q D) (F S) (J W) (H U) (V I) (A N) (O B) (E R) (F S) (L Y) (P C) (Z M))
'The goal of this task is to write a function that takes a string and can determine whether
'you can spell the word with the given collection of blocks.
'
'The rules are simple:
'1.Once a letter on a block is used that block cannot be used again
'2.The function should be case-insensitive
'3. Show your output on this page for the following words:
' A, BARK, BOOK, TREAT, COMMON, SQUAD, CONFUSE
'-----------------------------------------------------------------------------
' G l o b a l C o n s t a n t s
'
%Verbose = 0 'make this 1 to have a lot of feedback
%MAX_BLOCKS = 20 'total number of blocks
%MAX_SIDES = 2 'total number of sides containing a unique letter per block
%MAX_ASC = 255
%FALSE = 0 'this is correct because there is ONLY ONE value for FALSE
%TRUE = (NOT %FALSE) 'this is one of MANY values of TRUE!
$FLAG_TRUE = "1"
$FLAG_FALSE = "0"
'-----------------------------------------------------------------------------
' G l o b a l V a r i a b l e s
'
GLOBAL blk() AS STRING
'-----------------------------------------------------------------------------
'i n i t B l o c k s
'
' as we will use this array only once we build it each time program is run
'
SUB initBlocks
LOCAL j AS INTEGER
j=1
blk(j)="BO"
j=j+1
blk(j)="XK"
j=j+1
blk(j)="DQ"
j=j+1
blk(j)="CP"
j=j+1
blk(j)="NA"
j=j+1
blk(j)="GT"
j=j+1
blk(j)="RE"
j=j+1
blk(j)="TG"
j=j+1
blk(j)="QD"
j=j+1
blk(j)="FS"
j=j+1
blk(j)="JW"
j=j+1
blk(j)="HU"
j=j+1
blk(j)="VI"
j=j+1
blk(j)="AN"
j=j+1
blk(j)="OB"
j=j+1
blk(j)="ER"
j=j+1
blk(j)="FS"
j=j+1
blk(j)="LY"
j=j+1
blk(j)="PC"
j=j+1
blk(j)="ZM"
IF j <> %MAX_BLOCKS THEN
STDOUT "initBlocks:Error: j is not same as MAX_BLOCKS!",j,%MAX_BLOCKS
END IF
END SUB
'-----------------------------------------------------------------------------
' m a k e W o r d
'
FUNCTION makeWord(tryWord AS STRING) AS BYTE
LOCAL retTF AS BYTE
LOCAL j AS INTEGER
LOCAL s AS INTEGER 'which side of block we are looking at
LOCAL k AS INTEGER
LOCAL c AS STRING 'character in tryWord we are looking for
FOR j = 1 TO LEN(tryWord)
c = UCASE$(MID$(tryWord,j,1)) 'character we want to show with block
retTF = %FALSE 'we assume this will fail
FOR k = 1 TO %MAX_BLOCKS
IF LEN(blk(k)) = %MAX_SIDES THEN
FOR s = 1 TO %MAX_SIDES
IF c = MID$(blk(k),s,1) THEN
retTF = %TRUE 'this block has letter we want
blk(k) = "" 'remove this block from further consideration
EXIT FOR
END IF
NEXT s
END IF
IF retTF THEN EXIT FOR 'can go on to next character in word
NEXT k
IF ISFALSE retTF THEN EXIT FOR 'if character not found then all is done
NEXT j
FUNCTION = retTF
END FUNCTION
'-----------------------------------------------------------------------------
' P B M A I N
'
FUNCTION PBMAIN () AS LONG
DIM blk(1 TO %MAX_BLOCKS, 1 TO %MAX_SIDES) AS STRING
LOCAL cmdLine AS STRING
initBlocks 'setup global array of blocks
cmdLine=COMMAND$
IF LEN(cmdLine)= 0 THEN
STDOUT "Useage for ABCproblem Version 1.00:"
STDOUT ""
STDOUT " >ABCproblem tryThisWord"
STDOUT ""
STDOUT "Where tryThisWord is a word you want to see if"+STR$(%MAX_BLOCKS)+" blocks can make."
STDOUT "If word can be made TRUE is returned."
STDOUT "Otherwise FALSE is returned."
EXIT FUNCTION
END IF
IF INSTR(TRIM$(cmdLine)," ") = 0 THEN
IF makeWord(cmdLine) THEN
STDOUT "TRUE"
ELSE
STDOUT "FALSE"
END IF
ELSE
STDOUT "Error:Missing word to try to make with blocks! <" & cmdLine & ">"
EXIT FUNCTION
END IF
END FUNCTION

22
Task/ABC-Problem/Prolog/abc-problem.pro Normal file
View file

@ -0,0 +1,22 @@
abc_problem :-
maplist(abc_problem, ['', 'A', bark, bOOk, treAT, 'COmmon', sQuaD, 'CONFUSE']).
abc_problem(Word) :-
L = [[b,o],[x,k],[d,q],[c,p],[n,a],[g,t],[r,e],[t,g],[q,d],[f,s],
[j,w],[h,u],[v,i],[a,n],[o,b],[e,r],[f,s],[l,y],[p,c],[z,m]],
( abc_problem(L, Word)
-> format('~w OK~n', [Word])
; format('~w KO~n', [Word])).
abc_problem(L, Word) :-
atom_chars(Word, C_Words),
maplist(downcase_atom, C_Words, D_Words),
can_makeword(L, D_Words).
can_makeword(_L, []).
can_makeword(L, [H | T]) :-
( select([H, _], L, L1); select([_, H], L, L1)),
can_makeword(L1, T).

63
Task/ABC-Problem/Python/abc-problem-1.py Normal file
View file

@ -0,0 +1,63 @@
blocks = [("B", "O"),
("X", "K"),
("D", "Q"),
("C", "P"),
("N", "A"),
("G", "T"),
("R", "E"),
("T", "G"),
("Q", "D"),
("F", "S"),
("J", "W"),
("H", "U"),
("V", "I"),
("A", "N"),
("O", "B"),
("E", "R"),
("F", "S"),
("L", "Y"),
("P", "C"),
("Z", "M")]
def can_make_word(word, block_collection=blocks):
"""
Return True if `word` can be made from the blocks in `block_collection`.
>>> can_make_word("")
False
>>> can_make_word("a")
True
>>> can_make_word("bark")
True
>>> can_make_word("book")
False
>>> can_make_word("treat")
True
>>> can_make_word("common")
False
>>> can_make_word("squad")
True
>>> can_make_word("coNFused")
True
"""
if not word:
return False
blocks_remaining = block_collection[:]
for char in word.upper():
for block in blocks_remaining:
if char in block:
blocks_remaining.remove(block)
break
else:
return False
return True
if __name__ == "__main__":
import doctest
doctest.testmod()
print(", ".join("'%s': %s" % (w, can_make_word(w)) for w in
["", "a", "baRk", "booK", "treat",
"COMMON", "squad", "Confused"]))

25
Task/ABC-Problem/Python/abc-problem-2.py Normal file
View file

@ -0,0 +1,25 @@
BLOCKS = 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM'.split()
def _abc(word, blocks):
for i, ch in enumerate(word):
for blk in (b for b in blocks if ch in b):
whatsleft = word[i + 1:]
blksleft = blocks[:]
blksleft.remove(blk)
if not whatsleft:
return True, blksleft
if not blksleft:
return False, blksleft
ans, blksleft = _abc(whatsleft, blksleft)
if ans:
return ans, blksleft
else:
break
return False, blocks
def abc(word, blocks=BLOCKS):
return _abc(word.upper(), blocks)[0]
if __name__ == '__main__':
for word in [''] + 'A BARK BoOK TrEAT COmMoN SQUAD conFUsE'.split():
print('Can we spell %9r? %r' % (word, abc(word)))

16
Task/ABC-Problem/Python/abc-problem-3.py Normal file
View file

@ -0,0 +1,16 @@
def mkword(w, b):
if not w: return []
c,w = w[0],w[1:]
for i in range(len(b)):
if c in b[i]:
m = mkword(w, b[0:i] + b[i+1:])
if m != None: return [b[i]] + m
def abc(w, blk):
return mkword(w.upper(), [a.upper() for a in blk])
blocks = 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM'.split()
for w in ", A, bark, book, treat, common, SQUAD, conFUsEd".split(', '):
print '\'' + w + '\'' + ' ->', abc(w, blocks)

43
Task/ABC-Problem/R/abc-problem-1.r Normal file
View file

@ -0,0 +1,43 @@
blocks <- rbind(c("B","O"),
c("X","K"),
c("D","Q"),
c("C","P"),
c("N","A"),
c("G","T"),
c("R","E"),
c("T","G"),
c("Q","D"),
c("F","S"),
c("J","W"),
c("H","U"),
c("V","I"),
c("A","N"),
c("O","B"),
c("E","R"),
c("F","S"),
c("L","Y"),
c("P","C"),
c("Z","M"))
canMake <- function(x) {
x <- toupper(x)
used <- rep(FALSE, dim(blocks)[1L])
charList <- strsplit(x, character(0))
tryChars <- function(chars, pos, used, inUse=NA) {
if (pos > length(chars)) {
TRUE
} else {
used[inUse] <- TRUE
possible <- which(blocks == chars[pos] & !used, arr.ind=TRUE)[, 1L]
any(vapply(possible, function(possBlock) tryChars(chars, pos + 1, used, possBlock), logical(1)))
}
}
setNames(vapply(charList, tryChars, logical(1), 1L, used), x)
}
canMake(c("A",
"BARK",
"BOOK",
"TREAT",
"COMMON",
"SQUAD",
"CONFUSE"))

21
Task/ABC-Problem/R/abc-problem-2.r Normal file
View file

@ -0,0 +1,21 @@
canMakeNoRecursion <- function(x) {
x <- toupper(x)
charList <- strsplit(x, character(0))
getCombos <- function(chars) {
charBlocks <- data.matrix(expand.grid(lapply(chars, function(char) which(blocks == char, arr.ind=TRUE)[, 1L])))
charBlocks <- charBlocks[!apply(charBlocks, 1, function(row) any(duplicated(row))), , drop=FALSE]
if (dim(charBlocks)[1L] > 0L) {
t(apply(charBlocks, 1, function(row) apply(blocks[row, , drop=FALSE], 1, paste, collapse="")))
} else {
character(0)
}
}
setNames(lapply(charList, getCombos), x)
}
canMakeNoRecursion(c("A",
"BARK",
"BOOK",
"TREAT",
"COMMON",
"SQUAD",
"CONFUSE"))

1
Task/ABC-Problem/README Normal file
View file

@ -0,0 +1 @@
Data source: http://rosettacode.org/wiki/ABC_Problem

24
Task/ABC-Problem/REXX/abc-problem-1.rexx Normal file
View file

@ -0,0 +1,24 @@
/*REXX pgm checks if a word list can be spelt from a pool of toy blocks.*/
list = 'A bark bOOk treat common squaD conFuse' /*words can be any case.*/
blocks = 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM'
do k=1 for words(list) /*traipse through list of words. */
call spell word(list,k) /*show if word be spelt (or not).*/
end /*k*/ /* [↑] tests each word in list. */
exit /*stick a fork in it, we're done.*/
/*──────────────────────────────────SPELL subroutine────────────────────*/
spell: procedure expose blocks; parse arg ox . 1 x . /*get word to spell*/
z=blocks; upper x z; oz=z; p.=0; L=length(x) /*uppercase the blocks. */
/* [↓] try to spell it.*/
do try=1 for L; z=oz /*use a fresh copy of Z.*/
do n=1 for L; y=substr(x,n,1) /*attempt another letter*/
p.n=pos(y,z,1+p.n); if p.n==0 then iterate try /*¬ found? Try again.*/
z=overlay(' ',z,p.n) /*mutate block──► onesy.*/
do k=1 for words(blocks) /*scrub block pool (¬1s)*/
if length(word(z,k))==1 then z=delword(z,k,1) /*1 char? Delete.*/
end /*k*/ /* [↑] elide any onesy.*/
if n==L then leave try /*the last letter spelt?*/
end /*n*/ /* [↑] end of an attempt*/
end /*try*/ /* [↑] end TRY permute.*/
say right(ox,30) right(word("can't can", (n==L)+1), 6) 'be spelt.'
return n==L /*also, return the flag.*/

103
Task/ABC-Problem/REXX/abc-problem-2.rexx Normal file
View file

@ -0,0 +1,103 @@
/* REXX ---------------------------------------------------------------
* 10.01.2014 Walter Pachl counts the number of possible ways
* 12.01.2014 corrected date and output
*--------------------------------------------------------------------*/
show=(arg(1)<>'')
blocks = 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM'
list = '$ A baRk bOOk trEat coMMon squaD conFuse'
list=translate(list)
Do i=1 To words(blocks)
blkn.i=word(blocks,i)'-'i
blk.i=word(blocks,i)
End
w.=''
wlen=0
Do i=1 To words(list)
w.i=word(list,i)
wlen=max(wlen,length(w.i))
End
Do wi=0 To words(list)
word = w.wi
ways=0
poss.=0
lw=length(word)
cannot=0
Do i=1 To lw /* loop over the characters */
c=substr(word,i,1) /* the current character */
Do j=1 To words(blocks) /* loop over blocks */
blk=word(blocks,j)
If pos(c,blk)>0 Then Do /* block can be used in this position */
z=poss.i.0+1
poss.i.z=j
poss.i.0=z /* number of possible blocks for pos i */
End
End
If poss.i.0=0 Then Do
cannot=1
Leave i
End
End
If cannot=0 Then Do /* no prohibitive character */
s.=0
Do j=1 To poss.1.0 /* build possible strings for char 1 */
z=s.1.0+1
s.1.z=poss.1.j
s.1.0=z
End
Do i=2 To lw /* build possible strings for chars 1 to i */
ii=i-1
Do j=1 To poss.i.0
Do k=1 To s.ii.0
z=s.i.0+1
s.i.z=s.ii.k poss.i.j
s.i.0=z
End
End
End
Do p=1 To s.lw.0 /* loop through all possible strings */
v=valid(s.lw.p) /* test if the string is valid*/
If v Then Do /* it is */
ways=ways+1 /* increment number of ways */
way.ways='' /* and store the string's blocks */
Do ii=1 To lw
z=word(s.lw.p,ii)
way.ways=way.ways blk.z
End
End
End
End
/*---------------------------------------------------------------------
* now show the result
*--------------------------------------------------------------------*/
ol=left(''''word'''',wlen+2)
Select
When ways=0 Then
ol=ol 'cannot be spelt'
When ways=1 Then
ol=ol 'can be spelt'
Otherwise
ol=ol 'can be spelt in' ways 'ways'
End
Say ol'.'
If show Then Do
Do wj=1 To ways
Say copies(' ',10) way.wj
End
End
End
Exit
valid: Procedure
/*---------------------------------------------------------------------
* Check if the same block is used more than once -> 0
* Else: the combination is valid
*--------------------------------------------------------------------*/
Parse Arg list
used.=0
Do i=1 To words(list)
w=word(list,i)
If used.w Then Return 0
used.w=1
End
Return 1

43
Task/ABC-Problem/Racket/abc-problem.rkt Normal file
View file

@ -0,0 +1,43 @@
#lang racket
(define block-strings
(list "BO" "XK" "DQ" "CP" "NA"
"GT" "RE" "TG" "QD" "FS"
"JW" "HU" "VI" "AN" "OB"
"ER" "FS" "LY" "PC" "ZM"))
(define BLOCKS (map string->list block-strings))
(define (can-make-word? w)
(define (usable-block blocks word-char)
(for/first ((b (in-list blocks)) #:when (memf (curry char-ci=? word-char) b)) b))
(define (inner word-chars blocks tried-blocks)
(cond
[(null? word-chars) #t]
[(usable-block blocks (car word-chars))
=>
(lambda (b)
(or
(inner (cdr word-chars) (append tried-blocks (remove b blocks)) null)
(inner word-chars (remove b blocks) (cons b tried-blocks))))]
[else #f]))
(inner (string->list w) BLOCKS null))
(define WORD-LIST '("" "A" "BARK" "BOOK" "TREAT" "COMMON" "SQUAD" "CONFUSE"))
(define (report-word w)
(printf "Can we make: ~a? ~a~%"
(~s w #:min-width 9)
(if (can-make-word? w) "yes" "no")))
(module+ main
(for-each report-word WORD-LIST))
(module+ test
(require rackunit)
(check-true (can-make-word? ""))
(check-true (can-make-word? "A"))
(check-true (can-make-word? "BARK"))
(check-false (can-make-word? "BOOK"))
(check-true (can-make-word? "TREAT"))
(check-false (can-make-word? "COMMON"))
(check-true (can-make-word? "SQUAD"))
(check-true (can-make-word? "CONFUSE")))

Some files were not shown because too many files have changed in this diff Show more