ABC problem: Difference between revisions
| Line 2,066: | Line 2,066: | ||
var j: String |
var j: String |
||
for j in 0..blocks.count { |
for j in 0..blocks.count { |
||
if blocks[j]. |
if blocks[j].hasPrefix(CharString) || |
||
blocks[j]. |
blocks[j].hasSuffix(CharString) { |
||
final += char |
final += char |
||
blocks[j] = "" |
blocks[j] = "" |
||
Revision as of 16:02, 8 June 2014
You are encouraged to solve this task according to the task description, using any language you may know.
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>
Ada
Build with gnatchop abc.ada; gnatmake abc_problem
<lang ada>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; </lang>
Output:
A: TRUE BARK: TRUE BOOK: FALSE TREAT: TRUE COMMON: FALSE SQUAD: TRUE CONFUSE: TRUE
AutoHotkey
Function <lang autohotkey>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 } }</lang>
Test Input (as per question) <lang autohotkey>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</lang>
Output
A - 1 BARK - 1 BOOK - 0 TREAT - 1 COMMON - 0 SQUAD - 1 CONFUSE - 1
BBC BASIC
<lang bbcbasic> 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</lang>
Output:
A -> True BARK -> True BOOK -> False TREAT -> True COMMON -> False SQUAD -> True Confuse -> True
Bracmat
<lang bracmat>(
( 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 );</lang> Output:
A yes BARK yes BOOK no TREAT yes COMMON no SQUAD yes CONFUSE yes
C
Recursive solution. Empty string returns true. <lang c>#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; }</lang>
- Output:
1 A 1 BARK 1 BOOK 0 TREAT 1 COMMON 0 SQUAD 1 Confuse 1
C++
Uses C++11. Build with g++-4.7 -Wall -std=c++0x abc.cpp <lang cpp>#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";
}
}</lang>
Output:
A: true. BARK: true. BOOK: false. TREAT: true. COMMON: false. SQUAD: true. CONFUSE: true.
Clojure
A translation of the Haskell solution. <lang clojure> (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)))</lang>
- Output:
A: true BARK: true Book: false treat: true COMMON: false SQUAD: true CONFUSE: true
Common Lisp
<lang lisp> (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))))))))</lang>
- Output:
> (defparameter *blocks*
'("BO" "XK" "DQ" "CP" "NA" "GT" "RE" "TG" "QD" "FS"
"JW" "HU" "VI" "AN" "OB" "ER" "FS" "LY" "PC" "ZM"))
> (dolist (w '("" "A" "bArk" "BOOK" "trEAt" "CoMmoN" "squad" "conFUse"))
(format t "~s is possible: ~a~%" w (word-possible-p w *blocks*)))
"" is possible: T
"A" is possible: T
"bArk" is possible: T
"BOOK" is possible: NIL
"trEAt" is possible: T
"CoMmoN" is possible: NIL
"squad" is possible: T
"conFUse" is possible: T
NIL
> (word-possible-p "abba" '("AB" "AB" "AC" "AC"))
T
D
A simple greedy algorithm is enough for the given sequence of blocks. canMakeWord is true on an empty word because you can compose it using zero blocks. <lang d>import std.stdio, std.algorithm, std.string;
bool canMakeWord(in string word, in string[] blocks) pure /*nothrow*/ {
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() {
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));
}</lang>
- Output:
"" true "A" true "BARK" true "BoOK" false "TrEAT" true "COmMoN" false "SQUAD" true "conFUsE" true
Recursive Version
This version is able to find the solution for the word "abba" given the blocks AB AB AC AC.
<lang d>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));
}</lang>
- Output:
"" true "A" true "BARK" true "BoOK" false "TrEAT" true "COmMoN" false "SQUAD" true "conFUsE" true "abba" true
Alternative Recursive Version
This version doesn't shuffle the input blocks, but it's more complex and it allocates an array of indexes. <lang d>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));
}</lang> The output is the same.
FBSL
This approach uses a string, blanking out the pair previously found. Probably faster than array manipulation. <lang qbasic>
- 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 </lang> Output
A can be spelled with blocks. BARK can be spelled with blocks. BooK cannot be spelled with blocks. TrEaT can be spelled with blocks. comMON cannot be spelled with blocks. sQuAd can be spelled with blocks. Confuse can be spelled with blocks. Press any key to continue...
FORTRAN
Attempts to write the word read from unit 5. Please find the output, bash command, and gfortran compilation instructions as commentary at the start of the source, which starts right away! <lang FORTRAN> !-*- 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 </lang>
Go
<lang go>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)) } }</lang>
- Output:
A true BARK true BOOK false TREAT true COMMON false SQUAD true CONFUSE true
Harbour
Harbour Project implements a cross-platform Clipper/xBase compiler. <lang visualfoxpro>PROCEDURE Main()
LOCAL cStr
FOR EACH cStr IN { "A", "BARK", "BooK", "TrEaT", "comMON", "sQuAd", "Confuse" }
? PadL( cStr, 10 ), iif( Blockable( cStr ), "can", "cannot" ), "be spelled with blocks."
NEXT
RETURN
STATIC FUNCTION Blockable( cStr )
LOCAL blocks := { ;
"BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", ;
"JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM" }
LOCAL cFinal := "" LOCAL i, j
cStr := Upper( cStr )
FOR i := 1 TO Len( cStr )
FOR EACH j IN blocks
IF SubStr( cStr, i, 1 ) $ j
cFinal += SubStr( cStr, i, 1 )
j := ""
EXIT
ENDIF
NEXT
NEXT
RETURN cFinal == cStr</lang>
Output
A can be spelled with blocks.
BARK can be spelled with blocks.
BooK cannot be spelled with blocks.
TrEaT can be spelled with blocks.
comMON cannot be spelled with blocks.
sQuAd can be spelled with blocks.
Confuse can be spelled with blocks.
Haskell
The following function returns a list of all the solutions. Since Haskell is lazy, testing whether the list is null will only do the minimal amount of work necessary to determine whether a solution exists. <lang haskell>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"]</lang>
- Output:
("",True)
("A",True)
("BARK",True)
("BoOK",False)
("TrEAT",True)
("COmMoN",False)
("SQUAD",True)
("conFUsE",True)
Icon and Unicon
Works in both languages: <lang unicon>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</lang>
Sample run:
->abc "" A BARK BOOK TREAT COMMON SQUAD CONFUSE "" can be spelled with blocks. "A" can be spelled with blocks. "BARK" can be spelled with blocks. "BOOK" can not be spelled with blocks. "TREAT" can be spelled with blocks. "COMMON" can not be spelled with blocks. "SQUAD" can be spelled with blocks. "CONFUSE" can be spelled with blocks. ->
J
Solution: <lang j>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:</lang> Examples: <lang j> 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</lang>
Tacit version <lang j>delElem=: {~<@<@< uppc=:(-32*96&<*.123&>)&.(3&u:) reduc=: ] delElem 1 i.~e."0 1</lang>
Output <lang j> (,.[: a:&~:&.> Blocks&(reduc L:0/ :: (a:"_)@(<"0@],<@[))&.>@(uppc&.(;: inv))) ExampleWords ┌───────┬─┐ │A │1│ ├───────┼─┤ │BaRK │1│ ├───────┼─┤ │BOoK │0│ ├───────┼─┤ │tREaT │1│ ├───────┼─┤ │COmMOn │0│ ├───────┼─┤ │SqUAD │1│ ├───────┼─┤ │CoNfuSE│1│ └───────┴─┘</lang>
Alternative Implementation
Another approach might be:
<lang J>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
)</lang>
Example use:
<lang J> 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</lang>
Explanation:
We only need to consider blocks which contain letters in common with a normalized (upper case) version of the desired word. But we do need to consider all possible combinations of letters from those blocks (see talk page discussion of words like 'ABBA' for more on this issue).
We can classify possibilities by counting how many of each letter occur. If a candidate has at least as many of the required letters as a test case constructed from the word itself, it's a valid candidate.
Java
<lang java5>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));
} }</lang>
- Output:
"": true A: true BARK: true book: false treat: true COMMON: false SQuAd: true CONFUSE: true
JavaScript
ES6
<lang javascript>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)}`)); </lang>
Result:
A: true BARK: true BOOK: false TREAT: true COMMON: false SQUAD: true CONFUSE: true
Julia
<lang Julia>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</lang>
- Output:
julia> let test = ["A", "BARK","BOOK","TREAT","COMMON","SQUAD","CONFUSE"],
list = {"BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS",
"JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"}
for str in test
@printf("%-8s | %s\n", str, abc(str, list))
end
end
A | true
BARK | true
BOOK | false
TREAT | true
COMMON | false
SQUAD | true
CONFUSE | true
Mathematica
<lang Mathematica> 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
,
Template:Chars,blcks,chosen
]
] DoStep[opts_List]:=Flatten[DoStep@@@opts,1] ABCBlockQ[str_String]:=(FixedPoint[DoStep,{{Characters[ToLowerCase[str]],blocks,{}}}]=!={}) </lang>
- Output:
ABCBlockQ["A"] ABCBlockQ["BARK"] ABCBlockQ["BOOK"] ABCBlockQ["TREAT"] ABCBlockQ["COMMON"] ABCBlockQ["SQUAD"] ABCBlockQ["CONFUSE"] True True False True False True True
Perl
Recursive solution that can handle characters appearing on different blocks: <lang perl>#!/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
}</lang>
Testing: <lang perl>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); </lang>
Perl 6
Blocks are stored as precompiled regexes. We do an initial pass on the blockset to include in the list only those regexes that match somewhere in the current word. Conveniently, regexes scan the word for us. <lang perl6>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)";
}</lang>
- Output:
A True BaRK True BOoK False tREaT True COmMOn False SqUAD True CoNfuSE True
PHP
<lang PHP> <?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";
}</lang> Output:
A: True BARK: True BOOK: False TREAT: True COMMON: False SQUAD: True Confuse: True
PL/I
version 1
<lang pli>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;</lang>
A true BARK true BOOK false TREAT true COMMON false SQuAd true CONFUSE true
version 2
<lang pli>*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;</lang>
output
'$' cannot be spelt. 'A' can be spelt in 2 ways. 'BARK' can be spelt in 8 ways. 'BOOK' cannot be spelt. 'TREAT' can be spelt in 8 ways. 'COMMON' cannot be spelt. 'SQUAD' can be spelt in 8 ways. 'CONFUSE' can be spelt in 32 ways.
Prolog
Works with SWI-Prolog 6.5.3
<lang Prolog>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). </lang> Output :
?- abc_problem. OK A OK bark OK bOOk KO treAT OK COmmon KO sQuaD OK CONFUSE OK true.
Python
Python: Iterative, with tests
<lang python> 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"]))
</lang>
- Output:
'': False, 'a': True, 'baRk': True, 'booK': False, 'treat': True, 'COMMON': False, 'squad': True, 'Confused': True
Python: Recursive
<lang python>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)))</lang>
- Output:
Can we spell ''? False Can we spell 'A'? True Can we spell 'BARK'? True Can we spell 'BoOK'? False Can we spell 'TrEAT'? True Can we spell 'COmMoN'? False Can we spell 'SQUAD'? True Can we spell 'conFUsE'? True
Python: Recursive, telling how
<lang python>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)</lang>
- Output:
Note the case of empty list returned for empty string; whether it means true or false is up to you.
'' -> [] 'A' -> ['NA'] 'bark' -> ['BO', 'NA', 'RE', 'XK'] 'book' -> None 'treat' -> ['GT', 'RE', 'ER', 'NA', 'TG'] 'common' -> None 'SQUAD' -> ['FS', 'DQ', 'HU', 'NA', 'QD'] 'conFUsEd' -> ['CP', 'BO', 'NA', 'FS', 'HU', 'FS', 'RE', 'DQ']
Racket
I believe you can make an empty word by using no blocks. So '(can-make-word? "")' is true for me.
<lang racket>#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")))</lang>
- Output:
Can we make: "" ? yes Can we make: "A" ? yes Can we make: "BARK" ? yes Can we make: "BOOK" ? no Can we make: "TREAT" ? yes Can we make: "COMMON" ? no Can we make: "SQUAD" ? yes Can we make: "CONFUSE"? yes
REXX
version 1
<lang rexx>/*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.*/</lang> output
A can be spelt.
bark can be spelt.
bOOk can't be spelt.
treat can be spelt.
common can't be spelt.
squaD can be spelt.
conFuse can be spelt.
version 2
<lang rexx>/* 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</lang>
output
'' cannot be spelt. '$' cannot be spelt. 'A' can be spelt in 2 ways. 'BARK' can be spelt in 8 ways. 'BOOK' cannot be spelt. 'TREAT' can be spelt in 8 ways. 'COMMON cannot be spelt. 'SQUAD' can be spelt in 8 ways. 'CONFUS can be spelt in 32 ways.
extended output
'' cannot be spelt.
'$' cannot be spelt.
'A' can be spelt in 2 ways.
NA
AN
'BARK' can be spelt in 8 ways.
BO NA RE XK
OB NA RE XK
BO AN RE XK
OB AN RE XK
BO NA ER XK
OB NA ER XK
BO AN ER XK
OB AN ER XK
'BOOK' cannot be spelt.
'TREAT' can be spelt in 8 ways.
TG ER RE NA GT
TG RE ER NA GT
TG ER RE AN GT
TG RE ER AN GT
GT ER RE NA TG
GT RE ER NA TG
GT ER RE AN TG
GT RE ER AN TG
'COMMON' cannot be spelt.
'SQUAD' can be spelt in 8 ways.
FS QD HU NA DQ
FS QD HU NA DQ
FS QD HU AN DQ
FS QD HU AN DQ
FS DQ HU NA QD
FS DQ HU NA QD
FS DQ HU AN QD
FS DQ HU AN QD
'CONFUSE' can be spelt in 32 ways.
CP BO NA FS HU FS RE
PC BO NA FS HU FS RE
CP OB NA FS HU FS RE
PC OB NA FS HU FS RE
CP BO AN FS HU FS RE
PC BO AN FS HU FS RE
CP OB AN FS HU FS RE
PC OB AN FS HU FS RE
CP BO NA FS HU FS RE
PC BO NA FS HU FS RE
CP OB NA FS HU FS RE
PC OB NA FS HU FS RE
CP BO AN FS HU FS RE
PC BO AN FS HU FS RE
CP OB AN FS HU FS RE
PC OB AN FS HU FS RE
CP BO NA FS HU FS ER
PC BO NA FS HU FS ER
CP OB NA FS HU FS ER
PC OB NA FS HU FS ER
CP BO AN FS HU FS ER
PC BO AN FS HU FS ER
CP OB AN FS HU FS ER
PC OB AN FS HU FS ER
CP BO NA FS HU FS ER
PC BO NA FS HU FS ER
CP OB NA FS HU FS ER
PC OB NA FS HU FS ER
CP BO AN FS HU FS ER
PC BO AN FS HU FS ER
CP OB AN FS HU FS ER
PC OB AN FS HU FS ER
Ruby
This one uses a case insensitive regular expression. The 'sub!' method substitutes the first substring it finds and returns nil if nothing is found. <lang ruby>words = %w(A BaRK BOoK tREaT COmMOn SqUAD CoNfuSE) << ""
words.each do |word|
blocks = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM"
res = word.each_char.all?{|c| blocks.sub!(/\w?#{c}\w?/i, "")} #regexps can be interpolated like strings
puts "#{word.inspect}: #{res}"
end </lang>
- Output:
"A": true "BaRK": true "BOoK": false "tREaT": true "COmMOn": false "SqUAD": true "CoNfuSE": true "": true
Scala
<lang Scala>object AbcBlocks extends App {
protected class Block(face1: Char, face2: Char) {
def isFacedWith(that: Char) = { that == face1 || that == face2 }
override def toString() = face1.toString + face2
}
protected object Block {
def apply(faces: String) = new Block(faces.head, faces.last)
}
type word = Seq[Block]
private val blocks = List(Block("BO"), Block("XK"), Block("DQ"), Block("CP"), Block("NA"),
Block("GT"), Block("RE"), Block("TG"), Block("QD"), Block("FS"),
Block("JW"), Block("HU"), Block("VI"), Block("AN"), Block("OB"),
Block("ER"), Block("FS"), Block("LY"), Block("PC"), Block("ZM"))
private def isMakeable(word: String, blocks: word) = {
def getTheBlocks(word: String, blocks: word) = {
def inner(word: String, toCompare: word, rest: word, accu: word): word = {
if (word.isEmpty || rest.isEmpty || toCompare.isEmpty) accu
else if (toCompare.head.isFacedWith(word.head)) {
val restant = rest diff List(toCompare.head)
inner(word.tail, restant, restant, accu :+ toCompare.head)
} else inner(word, toCompare.tail, rest, accu)
}
inner(word, blocks, blocks, Nil)
}
word.lengthCompare(getTheBlocks(word, blocks).size) == 0 }
val words = List("A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSED", "ANBOCPDQERSFTGUVWXLZ")
// Automatic tests
assert(isMakeable(words(0), blocks))
assert(isMakeable(words(1), blocks))
assert(!isMakeable(words(2), blocks)) // BOOK not
assert(isMakeable(words(3), blocks))
assert(!isMakeable(words(4), blocks)) // COMMON not
assert(isMakeable(words(5), blocks))
assert(isMakeable(words(6), blocks))
assert(isMakeable(words(7), blocks))
//words(7).mkString.permutations.foreach(s => assert(isMakeable(s, blocks)))
words.foreach(w => println(s"$w can${if (isMakeable(w, blocks)) " " else "not "}be made."))
}</lang>
Seed7
<lang seed7>$ include "seed7_05.s7i";
const func boolean: canMakeWords (in array string: blocks, in string: word) is func
result
var boolean: okay is FALSE;
local
var integer: index is 1;
begin
if word = "" then
okay := TRUE;
elsif length(blocks) <> 0 then
while index <= length(blocks) and not okay do
if blocks[index][1] = word[1] or blocks[index][2] = word[1] then
okay := canMakeWords(blocks[.. pred(index)] & blocks[succ(index) ..], word[2 ..]);
end if;
incr(index);
end while;
end if;
end func;
const array string: blocks is [] ("BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM");
const func boolean: canMakeWords (in string: word) is
return canMakeWords(blocks, upper(word));
const proc: main is func
local
var string: word is "";
begin
for word range [] ("", "A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "Confuse") do
writeln(word rpad 10 <& canMakeWords(word));
end for;
end func;</lang>
- Output:
TRUE A TRUE BARK TRUE BOOK FALSE TREAT TRUE COMMON FALSE SQUAD TRUE Confuse TRUE
Swift
<lang Swift>func Blockable(str: String) -> Bool {
var blocks: String[] = [
"BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM" ]
var strUp = str.uppercaseString var final = "" var char: Character
for char in strUp {
var CharString: String = ""; CharString += char
var j: String
for j in 0..blocks.count {
if blocks[j].hasPrefix(CharString) ||
blocks[j].hasSuffix(CharString) {
final += char
blocks[j] = ""
break
}
}
}
return final == strUp
}
func CanOrNot(can: Bool) -> String {
return can ? "can" : "cannot"
}
var str: String
for str in [ "A", "BARK", "BooK", "TrEaT", "comMON", "sQuAd", "Confuse" ] {
println("'\(str)' \(CanOrNot(Blockable(str))) be spelled with blocks.")
}</lang>
- Output:
'A' can be spelled with blocks. 'BARK' can be spelled with blocks. 'BooK' cannot be spelled with blocks. 'TrEaT' can be spelled with blocks. 'comMON' cannot be spelled with blocks. 'sQuAd' can be spelled with blocks. 'Confuse' can be spelled with blocks.
Tcl
<lang tcl>package require Tcl 8.6
proc abc {word {blocks {BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM}}} {
set abc {{letters blocks abc} {
set rest [lassign $letters ch] set i 0 foreach blk $blocks { if {$ch in $blk && (![llength $rest] || [apply $abc $rest [lreplace $blocks $i $i] $abc])} { return true } incr i } return false
}}
return [apply $abc [split $word ""] [lmap b $blocks {split $b ""}] $abc]
}
foreach word {"" A BARK BOOK TREAT COMMON SQUAD CONFUSE} {
puts [format "Can we spell %9s? %s" '$word' [abc $word]]
}</lang>
- Output:
Can we spell ''? false Can we spell 'A'? true Can we spell 'BARK'? true Can we spell 'BOOK'? false Can we spell 'TREAT'? true Can we spell 'COMMON'? false Can we spell 'SQUAD'? true Can we spell 'CONFUSE'? true
TUSCRIPT
<lang tuscript>set words = "A'BARK'BOOK'TREAT'COMMON'SQUAD'CONFUSE" set result = * loop word = words
set blocks = "BO'XK'DQ'CP'NA'GT'RE'TG'QD'FS'JW'HU'VI'AN'OB'ER'FS'LY'PC'ZM"
set wordx = split (word, |"~</~")
set cond = "true"
loop char = wordx
set n = filter_index (blocks, "~*{char}*~", -)
if (n.eq."") then
set cond = "false"
exit
endif
set n2 = select (n, 1)
set n3 = select (blocks, #n2, blocks)
endloop
set out = concat (word, " ", cond)
set result = append (result, out)
endloop</lang>
- Output:
A true BARK true BOOK false TREAT true COMMON false SQUAD true CONFUSE true
TXR
<lang txr>@(do
(defvar 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)))
;; Define and build hash which maps each letter that occurs in blocks ;; to a list of the blocks in which that letter occurs.
(defvar alpha2blocks [hash-uni [group-by first blocks]
[group-by second blocks]
append])
;; convert, e.g. "abc" -> (A B C) ;; intern -- convert a string to an interned symbol ;; tok-str -- extract list of tokens from string which match a regex. ;; square brackets around mapcar -- Lisp-1 style evaluation, allowing ;; the intern function binding to be treated as a variable binding.
(defun string-to-syms (str)
[mapcar intern (tok-str (upcase-str str) #/./)])
;; Recursive part of algorithm working purely with Lisp symbols. ;; alpha -- single symbol denoting a letter ;; [alpha2blocks alpha] -- look up list of blocks for given letter ;; (memq item list) -- is item a member of list, under eq equality? ;; (remq item list) -- remove items from list which are eq to item.
(defun can-make-word-guts (letters blocks)
(cond
((null letters) t)
((null blocks) nil)
(t (let ((alpha (first letters)))
(each ((bl [alpha2blocks alpha]))
(if (and (memq bl blocks)
(can-make-word-guts (rest letters)
(remq bl blocks)))
(return-from can-make-word-guts t)))))))
(defun can-make-word (str)
(can-make-word-guts (string-to-syms str) blocks)))
@(repeat) @w @(output) >>> can_make_word("@(upcase-str w)") @(if (can-make-word w) "True" "False") @(end) @(end)</lang>
Run:
$ cat abc-problem.data
a
bark
book
treat
common
squad
confuse
$ txr abc-problem.txr abc-problem.data
>>> 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
zkl
<lang zkl>var blocks=T("BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM", );
fcn can_make_word(word){
fcn(blks,word){
if (not word) return(True); // bottom of recursion
foreach b in (blks){ n:=__bWalker._n;
if(not b.holds(word[0])) continue; // letter not on this block blks.del(n); // remove this block from pile if (self.fcn(blks,word[1,*])) return(True); // try remaining blocks blks.insert(n,b); // put block back in pile: backtracking
}
False; // out of blocks but not out of word
}(blocks.copy(),word.toUpper())
}
foreach word in (T("","A","BarK","BOOK","TREAT","COMMON","SQUAD","Confuse","abba")){
can_make_word(word).println(": ",word);
}</lang>
- Output:
True: True: A True: BarK False: BOOK True: TREAT False: COMMON True: SQUAD True: Confuse True: abba