ABC problem: Difference between revisions
No edit summary |
|||
Line 4,392: | Line 4,392: | ||
ok |
ok |
||
next |
next |
||
if found = false return |
if found = false return false ok |
||
next |
next |
||
return true</lang> |
return true</lang> |
||
Line 4,412: | Line 4,412: | ||
True |
True |
||
</pre> |
</pre> |
||
=={{header|Ruby}}== |
=={{header|Ruby}}== |
Revision as of 12:09, 8 February 2016
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>
Acurity Architect
Using #HASH-OFF
<lang acurity architect> FUNCTION bCAN_MAKE_WORD(zWord: STRING): BOOLEAN
VAR sBlockCount: SHORT VAR sWordCount: SHORT VAR sWordLength: SHORT VAR zLetter: STRING VAR zBlock: STRING VAR zBlockList: STRING VAR zUsedBlocks: STRING VAR zWord: STRING // SET zWord = UPPER(zWord) SET zBlockList = "BO,XK,DQ,CP,NA,GT,RE,TG,QD,FS,JW,HU,VI,AN,OB,ER,FS,LY,PC,ZM" SET sWordLength = LENGTH(zWord) // DO sWordCount = 1 TO sWordLength DO sBlockCount = 1 TO OCCURS(zBlockList, ",") SET zLetter = SUBSTR(zWord, sWordCount, 1) SET zBlock = GET_TOKEN(zBlockList, ",", sBlockCount) IF INDEX(zBlock, zLetter, 1) > 0 AND INDEX(zUsedBlocks, zBlock + STR(sBlockCount), 1) = 0 SET zUsedBlocks = zUsedBlocks + zBlock + STR(sBlockCount) + "," BREAK ENDIF ENDDO ENDDO RETURN OCCURS(zUsedBlocks, ",") = sWordLength
ENDFUNCTION </lang>
- Output:
bCAN_MAKE_WORD("A") returns TRUE bCAN_MAKE_WORD("BARK") returns TRUE bCAN_MAKE_WORD("BOOK") returns FALSE bCAN_MAKE_WORD("TREAT") returns TRUE bCAN_MAKE_WORD("COMMON") returns FALSE bCAN_MAKE_WORD("SQUAD") returns TRUE bCAN_MAKE_WORD("CONFUSE") returns TRUE
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
ALGOL 68
<lang algol68># determine whether we can spell words with a set of blocks #
- construct the list of blocks #
[][]STRING 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" ) );
- Returns TRUE if we can spell the word using the blocks, FALSE otherwise #
- Returns TRUE for an empty string #
PROC can spell = ( STRING word, [][]STRING blocks )BOOL:
BEGIN
# construct a set of flags to indicate whether the blocks are used # # or not # [ 1 LWB blocks : 1 UPB blocks ]BOOL used; FOR block pos FROM LWB used TO UPB used DO used[ block pos ] := FALSE OD;
# initialliy assume we can spell the word # BOOL result := TRUE;
# check we can spell the word with the set of blocks # FOR word pos FROM LWB word TO UPB word WHILE result DO CHAR c = IF is lower( word[ word pos ] ) THEN to upper( word[ word pos ] ) ELSE word[ word pos ] FI;
# look through the unused blocks for the current letter # BOOL found := FALSE; FOR block pos FROM 1 LWB blocks TO 1 UPB blocks WHILE NOT found DO IF ( c = blocks[ block pos ][ 1 ][ 1 ] OR c = blocks[ block pos ][ 2 ][ 1 ] ) AND NOT used[ block pos ] THEN # found an unused block with the required letter # found := TRUE; used[ block pos ] := TRUE FI OD;
result := found
OD;
result END; # can spell #
main: (
# test the can spell procedure # PROC test can spell = ( STRING word, [][]STRING blocks )VOID: write( ( ( "can spell: """ + word + """ -> " + IF can spell( word, blocks ) THEN "yes" ELSE "no" FI ) , newline ) );
test can spell( "A", blocks ); test can spell( "BaRK", blocks ); test can spell( "BOOK", blocks ); test can spell( "TREAT", blocks ); test can spell( "COMMON", blocks ); test can spell( "SQUAD", blocks ); test can spell( "CONFUSE", blocks )
) </lang> Output:
can spell: "A" -> yes can spell: "BaRK" -> yes can spell: "BOOK" -> no can spell: "TREAT" -> yes can spell: "COMMON" -> no can spell: "SQUAD" -> yes can spell: "CONFUSE" -> yes
ALGOL W
<lang algolw>% determine whether we can spell words with a set of blocks % begin
% Returns true if we can spell the word using the blocks, % % false otherwise % % As strings are fixed length in Algol W, the length of the string is % % passed as a separate parameter % logical procedure canSpell ( string(20) value word ; integer value wordLength ) ; begin
% convert a character to upper-case % % assumes the letters are contiguous in the character set % % as in ASCII and Unicode - not correct for EBCDIC % string(1) procedure toUpper( string(1) value c ) ; if c < "a" or c > "z" then c else code( ( decode( c ) - decode( "a" ) ) + decode( "A" ) ) ;
logical spellable; integer wordPos, blockPos; string(20) letters1, letters2;
% make local copies the faces so we can remove the used blocks % letters1 := face1; letters2 := face2;
% check we can spell the word with the set of blocks % spellable := true; wordPos := 0; while wordPos < wordLength and spellable do begin string(1) letter; letter := toUpper( word( wordPos // 1 ) ); if letter not = " " then begin spellable := false; blockPos := 0; while blockPos < 20 and not spellable do begin if letter = letters1( blockPos // 1 ) or letter = letters2( blockPos // 1 ) then begin % found the letter - remove the used block from the % % remaining blocks % letters1( blockPos // 1 ) := " "; letters2( blockPos // 1 ) := " "; spellable := true end; blockPos := blockPos + 1 end end; wordPos := wordPos + 1; end;
spellable end canSpell ;
% the letters available on the faces of the blocks % string(20) face1, face2; face1 := "BXDCNGRTQFJHVAOEFLPZ"; face2 := "OKQPATEGDSWUINBRSYCM";
begin % test the can spell procedure % procedure testCanSpell ( string(20) value word ; integer value wordLength ) ; write( if canSpell( word, wordLength ) then "can " else "cannot" , " spell """ , word , """" );
testCanSpell( "a", 1 ); testCanSpell( "bark", 4 ); testCanSpell( "BOOK", 4 ); testCanSpell( "treat", 5 ); testCanSpell( "commoN", 6 ); testCanSpell( "Squad", 5 ); testCanSpell( "confuse", 7 ) end
end.</lang>
- Output:
can spell "a " can spell "bark " cannot spell "BOOK " can spell "treat " cannot spell "commoN " can spell "Squad " can spell "confuse "
AppleScript
<lang AppleScript>set blocks to {"bo", "xk", "dq", "cp", "na", "gt", "re", "tg", "qd", "fs", "jw", "hu", "vi", "an", "ob", "er", "fs", "ly", "pc", "zm"}
canMakeWordWithBlocks("a", blocks) canMakeWordWithBlocks("bark", blocks) canMakeWordWithBlocks("book", blocks) canMakeWordWithBlocks("treat", blocks) canMakeWordWithBlocks("common", blocks) canMakeWordWithBlocks("squad", blocks) canMakeWordWithBlocks("confuse", blocks)
on canMakeWordWithBlocks(theString, constBlocks) copy constBlocks to theBlocks if theString = "" then return true set i to 1 repeat if i > (count theBlocks) then exit repeat if character 1 of theString is in item i of theBlocks then set item i of theBlocks to missing value set theBlocks to strings of theBlocks if canMakeWordWithBlocks(rest of characters of theString as string, theBlocks) then return true end if end if set i to i + 1 end repeat return false end canMakeWordWithBlocks </lang>
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
Batch File
<lang dos> @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
</lang>
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.
C#
Regex
This Method uses regular expressions to do the checking. Given that n = length of blocks string and m = length of word string, then CheckWord's time complexity comes out to about m*(n - (m-1)/2). <lang csharp>using System; using System.IO; // Needed for the method. using System.Text.RegularExpressions; using System.Collections.Generic;
void Main() {
string blocks = "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" };
foreach(var word in words) { Console.WriteLine("{0}: {1}", word, CheckWord(blocks, word)); }
}
bool CheckWord(string blocks, string word) {
for(int i = 0; i < word.Length; ++i) { int length = blocks.Length; Regex rgx = new Regex("([a-z]"+word[i]+"|"+word[i]+"[a-z])", RegexOptions.IgnoreCase); blocks = rgx.Replace(blocks, "", 1); if(blocks.Length == length) return false; } return true;
} </lang>
- Output:
A: True BARK: True BOOK: False TREAT: True COMMON: False SQUAD: True CONFUSE: True
Unoptimized <lang csharp>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; } } </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
CoffeeScript
<lang CoffeeScript>blockList = [ 'BO', 'XK', 'DQ', 'CP', 'NA', 'GT', 'RE', 'TG', 'QD', 'FS', 'JW', 'HU', 'VI', 'AN', 'OB', 'ER', 'FS', 'LY', 'PC', 'ZM' ]
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 false # Return true if there are no falsy values false not in (checkBlocks letter for letter in word)
- Expect true, true, false, true, false, true, true, true
for word in ["A", "BARK", "BOOK", "TREAT", "COMMON", "squad", "CONFUSE", "STORM"]
console.log word + " -> " + canMakeWord(word)</lang>
- Output:
A -> true BARK -> true BOOK -> false TREAT -> true COMMON -> false squad -> true CONFUSE -> true STORM -> 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
Basic Version
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*/ @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));
}</lang>
- Output:
"" true "A" true "BARK" true "BoOK" false "TrEAT" true "COmMoN" false "SQUAD" true "conFUsE" true
@nogc Version
The same as the precedent version, but it avoids all heap allocations and it's lower-level and ASCII-only. <lang d>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));
}</lang>
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.
Delphi
Just to be different I implemented a block as a set of (2) char rather than as an array of (2) char. <lang Delphi>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. </lang>
- Output:
Output: Can make A Can make BARK Can NOT make BOOK Can make TREAT Can NOT make COMMON Can make SQUAD Can make CONFUSE
Elixir
<lang elixir>defmodule ABC do
def can_make_word(word, avail) do can_make_word(String.upcase(word) |> to_char_list, avail, []) end defp can_make_word([], _, _), do: true defp can_make_word(_, [], _), do: false defp can_make_word([l|tail], [b|rest], tried) do (Enum.member?(b,l) and can_make_word(tail, rest++tried, [])) or can_make_word([l|tail], rest, [b|tried]) end
end
blocks = ~w(BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM)c ~w(A Bark Book Treat Common Squad Confuse) |> Enum.map(fn(w) -> IO.puts "#{w}: #{ABC.can_make_word(w, blocks)}" end)</lang>
- Output:
A: true Bark: true Book: false Treat: true Common: false Squad: true Confuse: true
Erlang
<lang erlang>-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"]).
</lang>
- Output:
A: true Bark: true Book: false Treat: true Common: false Squad: true Confuse: true
ERRE
<lang ERRE> PROGRAM BLOCKS
!$INCLUDE="PC.LIB"
PROCEDURE CANMAKEWORD(WORD$)
LOCAL B$,P% B$=BLOCKS$ PRINT(WORD$;" -> ";) P%=INSTR(B$,CHR$(ASC(WORD$) AND $DF)) WHILE P%>0 AND WORD$>"" DO CHANGE(B$,P%-1+(P% MOD 2),".."->B$) WORD$=MID$(WORD$,2) EXIT IF WORD$="" P%=INSTR(B$,CHR$(ASC(WORD$) AND $DF)) END WHILE IF WORD$>"" THEN PRINT("False") ELSE PRINT("True") END IF
END PROCEDURE
BEGIN
BLOCKS$="BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM" CANMAKEWORD("A") CANMAKEWORD("BARK") CANMAKEWORD("BOOK") CANMAKEWORD("TREAT") CANMAKEWORD("COMMON") CANMAKEWORD("SQUAD") CANMAKEWORD("Confuse")
END PROGRAM </lang>
Euphoria
implemented using OpenEuphoria <lang Euphoria> 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 </lang>
- Output:
A: TRUE BarK: TRUE BOOK: FALSE TrEaT: TRUE COMMON: FALSE SQUAD: TRUE CONFUSE: TRUE ..press Enter..
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
Groovy
Solution: <lang groovy>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) }) } }
}</lang>
Test: <lang groovy>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)}"
}</lang>
- Output:
'': true '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 forms=: (1 - -: (reduc L:0/ :: (a:"_)@(<"0@],<@[))&uppc) L:0</lang>
- Output:
(,.Blocks&forms) ExampleWords ┌───────┬─┐ │A │1│ ├───────┼─┤ │BaRK │1│ ├───────┼─┤ │BOoK │0│ ├───────┼─┤ │tREaT │1│ ├───────┼─┤ │COmMOn │0│ ├───────┼─┤ │SqUAD │1│ ├───────┼─┤ │CoNfuSE│1│ └───────┴─┘
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.
For example:
<lang J> Blocks canform 0{::ExampleWords 1
word
A
need
2
relevant
NA AN
candidates
ANA ANN AAA AAN</lang>
Here, the word is simply 'A', and we have two blocks to consider for our word: AN and NA. So we form all possible combinations of the letters of those two bocks, prefix each of them with our word and test whether any of them contain two copies of the letters of our word. (As it happens, all of the candidates are valid, for this trivial example.)
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
Regex
The following method uses regular expressions and the string replace function to allow more support for older browsers. <lang javascript>var blocks = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM";
function CheckWord(blocks, word) {
// Makes sure that word only contains letters. if(word !== /([a-z]*)/i.exec(word)[1]) return false; // Loops through each character to see if a block exists. for(var i = 0; i < word.length; ++i) { // Gets the ith character. var letter = word.charAt(i); // Stores the length of the blocks to determine if a block was removed. var length = blocks.length; // The regexp gets constructed by eval to allow more browsers to use the function. var reg = eval("/([a-z]"+letter+"|"+letter+"[a-z])/i"); // This does the same as above, but some browsers do not support... //var reg = new RegExp("([a-z]"+letter+"|"+letter+"[a-z])", "i"); // Removes all occurrences of the match. blocks = blocks.replace(reg, ""); // If the length did not change then a block did not exist. if(blocks.length === length) return false; } // If every character has passed then return true. return true;
};
var words = [
"A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"
];
for(var i = 0;i<words.length;++i)
console.log(words[i] + ": " + CheckWord(blocks, words[i]));
</lang>
Result:
A: true BARK: true BOOK: false TREAT: true COMMON: false SQUAD: true CONFUSE: true
Functional (ES 5)
<lang JavaScript>(function (strWords) {
var strBlocks = 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM', blocks = strBlocks.split(' ');
function abc(lstBlocks, strWord) { var lngChars = strWord.length;
if (!lngChars) return [];
var b = lstBlocks[0], c = strWord[0];
return chain(lstBlocks, function (b) { return (b.indexOf(c.toUpperCase()) !== -1) ? [ (b + ' ').concat( abc(removed(b, lstBlocks), strWord.slice(1))) ] : []; }) }
// Monadic bind (chain) for lists function chain(xs, f) { return [].concat.apply([], xs.map(f)); }
// a -> [a] -> [a] function removed(x, xs) { var h = xs.length ? xs[0] : null, t = h ? xs.slice(1) : [];
return h ? ( h === x ? t : [h].concat(removed(x, t)) ) : []; }
function solution(strWord) { var strAttempt = abc(blocks, strWord)[0].split(',')[0];
// two chars per block plus one space -> 3 return strWord + ((strAttempt.length === strWord.length * 3) ? ' -> ' + strAttempt : ': [no solution]'); }
return strWords.split(' ').map(solution).join('\n');
})('A bark BooK TReAT COMMON squAD conFUSE');</lang>
- Output:
<lang JavaScript>A -> NA bark -> BO NA RE XK BooK: [no solution] TReAT -> GT RE ER NA TG COMMON: [no solution] squAD -> FS DQ HU NA QD conFUSE -> CP BO NA FS HU FS RE</lang>
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
jq
The problem description seems to imply that if a letter, X, appears on more than one block, its partner will be the same on all blocks. This makes the problem trivial.<lang jq>
- when_index(cond;ary) returns the index of the first element in ary
- that satisfies cond; it uses a helper function that takes advantage
- of tail-recursion optimization in recent versions of jq.
def index_when(cond; ary):
# state variable: counter def when: if . >= (ary | length) then null elif ary[.] | cond then . else (.+1) | when end; 0 | when;
- Attempt to match a single letter with a block;
- return null if no match, else the remaining blocks
def match_letter(letter):
. as $ary | index_when( index(letter); $ary ) as $ix | if $ix == null then null else del( .[$ix] ) end;
- Usage: string | abc(blocks)
def abc(blocks):
if length == 0 then true else .[0:1] as $letter | (blocks | match_letter( $letter )) as $blks | if $blks == null then false else .[1:] | abc($blks) end end;</lang>
Task:<lang jq>def task:
["BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS", "JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"] as $blocks | ("A", "BARK","BOOK","TREAT","COMMON","SQUAD","CONFUSE") | "\(.) : \( .|abc($blocks) )" ;task</lang>
- Output:
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 = eachindex(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
Kotlin
<lang scala>package abc
object ABC_block_checker {
fun run() { val blocks = arrayOf("BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM")
println("\"\": " + blocks.canMakeWord("")) val words = arrayOf("A", "BARK", "book", "treat", "COMMON", "SQuAd", "CONFUSE") for (w in words) println("$w: " + blocks.canMakeWord(w)) }
private fun Array<String>.swap(i: Int, j: Int) { val tmp = this[i] this[i] = this[j] this[j] = tmp }
private fun Array<String>.canMakeWord(word: String): Boolean { if (word.length == 0) return true
val c = Character.toUpperCase(word.first()) var i = 0 forEach { b -> if (b.first().toUpperCase() == c || b[1].toUpperCase() == c) { swap(0, i) if (drop(1).toTypedArray().canMakeWord(word.substring(1))) return true swap(0, i) } i++ }
return false }
}
fun main(args: Array<String>) = ABC_block_checker.run()</lang>
- Output:
"": true A: true BARK: true book: false treat: true COMMON: false SQuAd: true CONFUSE: true
Logo
<lang logo>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</lang>
- Output:
A: true BARK: true BOOK: false TREAT: true COMMON: false SQUAD: true CONFUSE: true
Lua
<lang lua>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"}; };
function canUse(table, letter) for i,v in pairs(blocks) do if (v[1] == letter:upper() or v[2] == letter:upper()) and table[i] then table[i] = false; return true; end end return false; end
function canMake(Word) local Taken = {}; for i,v in pairs(blocks) do table.insert(Taken,true); end local found = true; for i = 1,#Word do if not canUse(Taken,Word:sub(i,i)) then found = false; end end print(found) end</lang>
- Output:
canMake("A"): true canMake("BARK"): true canMake("BOOK"): false canMake("TREAT"): true canMake("COMMON"): false canMake("SQUAD"): true canMake("CONFUSE"): true
Mathematica / Wolfram Language
<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
MATLAB
<lang MATLAB>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</lang>
- Output:
Can make word A. Can make word BARK. CanNOT make word BOOK. Can make word TREAT. CanNOT make word COMMON. Can make word SQUAD. Can make word CONFUSE.
MAXScript
Recursive
Recursively checks if the word is possible if a block is removed from the array.
<lang MAXScript> -- 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 ) ) </lang>
Output: <lang MAXScript> iswordpossible "a" true iswordpossible "bark" true iswordpossible "book" false iswordpossible "treat" true iswordpossible "common" false iswordpossible "squad" true iswordpossible "confuse" true </lang>
Non-recursive
<lang MAXScript> 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 ) </lang>
Both versions are good for this example, but the non-recursive version won't work if the blocks are more random, because it just takes the first found block, and the recursive version decides which one to use. For example, if blocks are: #("RT","WA","WO","TB","RE") Then:
<lang MAXScript> iswordpossible "water" true iswordpossible2 "water" false </lang>
Non-recursive version quickly decides that it's not possible, even though it clearly is.
Nim
<lang nim>from strutils import contains, format, toUpper from sequtils import delete
proc canMakeWord(s: string): bool =
var abcs = @["BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"] matched = newSeq[string]()
if s.len > abcs.len: return false
for i in 0 .. s.len - 1: var letter = s[i].toUpper n = 0 for abc in abcs: if contains(abc, letter): delete(abcs, n, n) matched = matched & abc break else: inc(n)
if matched.len == s.len: return true else: return false
var words = @["A", "bArK", "BOOK", "treat", "common", "sQuAd", "CONFUSE"] for word in words:
echo format("Can the blocks make the word \"$1\"? $2", word, (if canMakeWord(word): "yes" else: "no"))</lang>
- Output:
Can the blocks make the word "A"? yes Can the blocks make the word "bArK"? yes Can the blocks make the word "BOOK"? no Can the blocks make the word "treat"? yes Can the blocks make the word "common"? no Can the blocks make the word "sQuAd"? yes Can the blocks make the word "CONFUSE"? yes
Oberon-2
Works with oo2c Version 2 <lang oberon2> 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. </lang> Output:
A: TRUE BARK: TRUE BOOK: FALSE TREAT: TRUE COMMON: FALSE SQAD: TRUE confuse: TRUE
Objeck
<lang objeck>class Abc {
function : Main(args : String[]) ~ Nil { blocks := ["BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"]; IO.Console->Print("\"\": ")->PrintLine(CanMakeWord("", blocks)); IO.Console->Print("A: ")->PrintLine(CanMakeWord("A", blocks)); IO.Console->Print("BARK: ")->PrintLine(CanMakeWord("BARK", blocks)); IO.Console->Print("book: ")->PrintLine(CanMakeWord("book", blocks)); IO.Console->Print("treat: ")->PrintLine(CanMakeWord("treat", blocks)); IO.Console->Print("COMMON: ")->PrintLine(CanMakeWord("COMMON", blocks)); IO.Console->Print("SQuAd: ")->PrintLine(CanMakeWord("SQuAd", blocks)); IO.Console->Print("CONFUSE: ")->PrintLine(CanMakeWord("CONFUSE", blocks)); } function : CanMakeWord(word : String, blocks : String[]) ~ Bool { if(word->Size() = 0) { return true; }; c := word->Get(0)->ToUpper(); for(i := 0; i < blocks->Size(); i++;) { b := blocks[i]; if(<>(b->Get(0)->ToUpper() <> c & b->Get(1)->ToUpper() <> c)) { Swap(0, i, blocks); new_word := word->SubString(1, word->Size() - 1); new_blocks := String->New[blocks->Size() - 1]; Runtime->Copy(new_blocks, 0, blocks, 1, blocks->Size() - 1); if(CanMakeWord(new_word, new_blocks)) { return true; }; Swap(0, i, blocks); }; }; return false; } function : native : Swap(i : Int, j : Int, arr : String[]) ~ Nil { tmp := arr[i]; arr[i] := arr[j]; arr[j] := tmp; }
}</lang>
"": true A: true BARK: true book: false treat: true COMMON: false SQuAd: true CONFUSE: true
OCaml
<lang ocaml>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; ]</lang>
- Output:
$ ocaml canmakeword.ml - can make word "A" = true (should: true) - can make word "BARK" = true (should: true) - can make word "BOOK" = false (should: false) - can make word "TREAT" = true (should: true) - can make word "COMMON" = false (should: false) - can make word "SQUAD" = true (should: true) - can make word "CONFUSE" = true (should: true)
Oforth
<lang Oforth>["BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS","JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"] const: ABCBlocks
- canMakeWord(w, blocks)
| i |
w isEmpty ifTrue: [ true return ] blocks size loop: i [ blocks at(i) include(w first toUpper) ifFalse: [ continue ] canMakeWord(w right(w size 1 -), blocks del(i, i)) ifTrue: [ true return ] ] false ;</lang>
- Output:
["A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"] map(#[ ABCBlocks canMakeWord]) println [1, 1, 0, 1, 0, 1, 1]
OpenEdge/Progress
<lang Progress (Openedge ABL)>FUNCTION canMakeWord RETURNS LOGICAL (INPUT pWord AS CHARACTER) FORWARD.
/* List of blocks */ DEFINE TEMP-TABLE ttBlocks NO-UNDO
FIELD ttFaces AS CHARACTER FORMAT "x(1)" EXTENT 2 FIELD ttUsed AS LOGICAL.
/* Fill in list of blocks */ RUN AddBlock("BO"). RUN AddBlock("XK"). RUN AddBlock("DQ"). RUN AddBlock("CP"). RUN AddBlock("NA"). RUN AddBlock("GT"). RUN AddBlock("Re"). RUN AddBlock("TG"). RUN AddBlock("QD"). RUN AddBlock("FS"). RUN AddBlock("JW"). RUN AddBlock("HU"). RUN AddBlock("VI"). RUN AddBlock("AN"). RUN AddBlock("OB"). RUN AddBlock("ER"). RUN AddBlock("FS"). RUN AddBlock("LY"). RUN AddBlock("PC"). RUN AddBlock("ZM").
DEFINE VARIABLE chWords AS CHARACTER EXTENT 7 NO-UNDO. ASSIGN chWords[1] = "A"
chWords[2] = "BARK" chWords[3] = "BOOK" chWords[4] = "TREAT" chWords[5] = "COMMON" chWords[6] = "SQUAD" chWords[7] = "CONFUSE".
DEFINE FRAME frmResult
WITH NO-LABELS 7 DOWN USE-TEXT.
DEFINE VARIABLE i AS INTEGER NO-UNDO. DO i = 1 TO 7:
DISPLAY chWords[i] + " = " + STRING(canMakeWord(chWords[i])) FORMAT "x(25)" WITH FRAME frmResult. DOWN WITH FRAME frmResult.
END.
PROCEDURE AddBlock:
DEFINE INPUT PARAMETER i-chBlockvalue AS CHARACTER NO-UNDO.
IF (LENGTH(i-chBlockValue) <> 2) THEN RETURN ERROR.
CREATE ttBlocks. ASSIGN ttBlocks.ttFaces[1] = SUBSTRING(i-chBlockValue, 1, 1) ttBlocks.ttFaces[2] = SUBSTRING(i-chBlockValue, 2, 1).
END PROCEDURE.
FUNCTION blockInList RETURNS LOGICAL (pChar AS CHARACTER):
/* Find first unused block in list */ FIND FIRST ttBlocks WHERE (ttBlocks.ttFaces[1] = pChar OR ttBlocks.ttFaces[2] = pChar) AND NOT ttBlocks.ttUsed NO-ERROR. IF (AVAILABLE ttBlocks) THEN DO: /* found it! set to used and return true */ ASSIGN ttBlocks.ttUsed = TRUE. RETURN TRUE. END. ELSE RETURN FALSE.
END FUNCTION.
FUNCTION canMakeWord RETURNS LOGICAL (INPUT pWord AS CHARACTER):
DEFINE VARIABLE i AS INTEGER NO-UNDO. DEFINE VARIABLE chChar AS CHARACTER NO-UNDO.
/* Word has to be valid */ IF (LENGTH(pWord) = 0) THEN RETURN FALSE.
DO i = 1 TO LENGTH(pWord): /* get the char */ chChar = SUBSTRING(pWord, i, 1).
/* Check to see if this is a letter? */ IF ((ASC(chChar) < 65) OR (ASC(chChar) > 90) AND (ASC(chChar) < 97) OR (ASC(chChar) > 122)) THEN RETURN FALSE.
/* Is block is list (and unused) */ IF NOT blockInList(chChar) THEN RETURN FALSE. END.
/* Reset all blocks */ FOR EACH ttBlocks: ASSIGN ttUsed = FALSE. END. RETURN TRUE.
END FUNCTION. </lang>
- Output:
A = yes BARK = yes BOOK = no TREAT = yes COMMON = no SQUAD = yes CONFUSE = yes
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.list, @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, list @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
Phix
<lang Phix> -- Here is my recursive solution which also solves the extra problems on the discussion page:
sequence blocks = {"BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS",
"JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"}
sequence words = {"","A","BarK","BOOK","TrEaT","COMMON","SQUAD","CONFUSE"}
--sequence blocks = {"US","TZ","AO","QA"} --sequence words = {"AuTO"}
--sequence blocks = {"AB","AB","AC","AC"} --sequence words = {"abba"}
sequence used = repeat(0,length(blocks))
function ABC_Solve(sequence word, integer idx) integer ch integer res = 0
if idx>length(word) then res = 1 else ch = word[idx] for k=1 to length(blocks) do if used[k]=0 and find(ch,blocks[k]) then used[k] = 1 res = ABC_Solve(word,idx+1) used[k] = 0 if res then exit end if end if end for end if return res
end function
constant TF = {"False","True"} procedure ABC_Problem()
for i=1 to length(words) do printf(1,"%s: %s\n",{words[i],TF[ABC_Solve(upper(words[i]),1)+1]}) end for if getc(0) then end if
end procedure
ABC_Problem()
</lang>
- Output:
: True 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
PicoLisp
Mapping and recursion. <lang>(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)</lang>
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.
PowerBASIC
Works with PowerBASIC 6 Console Compiler
<lang PowerBASIC>#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 </lang>
- Output:
$ FALSE A TRUE bark TRUE bOOk FALSE treAT TRUE COmmon FALSE sQuaD TRUE CONFUSE TRUE GearyChopoff TRUE
PowerShell
<lang powershell><# .Synopsis
ABC Problem
.DESCRIPTION
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 blocks = "BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS","JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM" 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: >>> 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
Using the examples below you can either see just the value or status and the values using the verbose switch
.EXAMPLE
test-blocks -testword confuse
.EXAMPLE
test-blocks -testword confuse -verbose
- >
function test-blocks { [CmdletBinding()] # [OutputType([int])] Param ( # word to test against blocks [Parameter(Mandatory = $true, ValueFromPipelineByPropertyName = $true)] $testword
)
$word = $testword
#define array of blocks [System.Collections.ArrayList]$blockarray = "BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"
#send word to chararray $chararray = $word.ToCharArray() $chars = $chararray
#get the character count $charscount = $chars.count
#get the initial count of the blocks $blockcount = $blockarray.Count
#find out how many blocks should be left from the difference #of the blocks and characters in the word - 1 letter/1 block $correctblockcount = $blockcount - $charscount
#loop through the characters in the word foreach ($char in $chars) {
#loop through the blocks foreach ($block in $blockarray) {
#check the current character against each letter on the current block #and break if found so the array can reload if ($char -in $block[0] -or $char -in $block[1]) {
write-verbose "match for letter - $char - removing block $block" $blockarray.Remove($block) break
}
}
} #get final count of blocks left in array to determine if the word was #correctly made $finalblockcount = $blockarray.count if ($finalblockcount -ne $correctblockcount) { write-verbose "$word : $false " return $false } else { write-verbose "$word : $true " return $true }
}
- loop all the words and pass them to the function
$wordlist = "a", "bark", "book", "treat", "common", "squad", "confuse" foreach ($word in $wordlist) { test-blocks -testword $word -Verbose }</lang>
- Output:
VERBOSE: match for letter - a - removing block NA VERBOSE: a : True True VERBOSE: match for letter - b - removing block BO VERBOSE: match for letter - a - removing block NA VERBOSE: match for letter - r - removing block RE VERBOSE: match for letter - k - removing block XK VERBOSE: bark : True True VERBOSE: match for letter - b - removing block BO VERBOSE: match for letter - o - removing block OB VERBOSE: match for letter - k - removing block XK VERBOSE: book : False False VERBOSE: match for letter - t - removing block GT VERBOSE: match for letter - r - removing block RE VERBOSE: match for letter - e - removing block ER VERBOSE: match for letter - a - removing block NA VERBOSE: match for letter - t - removing block TG VERBOSE: treat : True True VERBOSE: match for letter - c - removing block CP VERBOSE: match for letter - o - removing block BO VERBOSE: match for letter - m - removing block ZM VERBOSE: match for letter - o - removing block OB VERBOSE: match for letter - n - removing block NA VERBOSE: common : False False VERBOSE: match for letter - s - removing block FS VERBOSE: match for letter - q - removing block DQ VERBOSE: match for letter - u - removing block HU VERBOSE: match for letter - a - removing block NA VERBOSE: match for letter - d - removing block QD VERBOSE: squad : True True VERBOSE: match for letter - c - removing block CP VERBOSE: match for letter - o - removing block BO VERBOSE: match for letter - n - removing block NA VERBOSE: match for letter - f - removing block FS VERBOSE: match for letter - u - removing block HU VERBOSE: match for letter - s - removing block FS VERBOSE: match for letter - e - removing block RE VERBOSE: confuse : True True or without verbose True True False True False True True
Prolog
Traditional
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.
Constraint Handling Rules
An approach using [CHR https://dtai.cs.kuleuven.be/CHR/] via SWI-Prolog's [library(chr) http://www.swi-prolog.org/pldoc/man?section=chr] and a module I'm working on for composing predicates composer:
<lang Prolog>:- use_module([ library(chr),
abathslib(protelog/composer) ]).
- - chr_constraint blocks, block/1, letter/1, word_built.
can_build_word(Word) :-
maplist(block, [(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)]), maplist(letter) <- string_chars <- string_lower(Word), %% using the `composer` module word_built, !.
'take letter and block' @ letter(L), block((A,B)) <=> L == A ; L == B | true. 'fail if letters remain' @ word_built, letter(_) <=> false.
%% These rules, removing remaining constraints from the store, are just cosmetic: 'clean up blocks' @ word_built \ block(_) <=> true. 'word was built' @ word_built <=> true.</lang>
Demonstration:
<lang Prolog>?- can_build_word("A"). true. ?- can_build_word("BARK"). true. ?- can_build_word("BOOK"). false. ?- can_build_word("TREAT"). true. ?- can_build_word("COMMON"). false. ?- can_build_word("SQUAD"). true. ?- can_build_word("CONFUSE"). true.</lang>
PureBasic
PureBasic: Iterative
<lang purebasic>EnableExplicit
- LETTERS = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM "
Procedure.s can_make_word(word.s)
Define.s letters = #LETTERS, buffer Define.i index1, index2 Define.b match For index1=1 To Len(word) index2=1 : match=#False Repeat buffer=StringField(letters,index2,Space(1)) If FindString(buffer,Mid(word,index1,1),1,#PB_String_NoCase) letters=RemoveString(letters,buffer+Chr(32),0,1,1) match=#True Break EndIf index2+1 Until index2>CountString(letters,Space(1)) If Not match : ProcedureReturn word+#TAB$+"FALSE" : EndIf Next ProcedureReturn word+#TAB$+"TRUE"
EndProcedure
OpenConsole() PrintN(can_make_word("a")) PrintN(can_make_word("BaRK")) PrintN(can_make_word("BOoK")) PrintN(can_make_word("TREAt")) PrintN(can_make_word("cOMMON")) PrintN(can_make_word("SqUAD")) PrintN(can_make_word("COnFUSE")) Input()</lang>
PureBasic: Recursive
<lang purebasic>Define.i
- LETTERS = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM "
Macro test(t)
Print(t+#TAB$+#TAB$+"= ") : If can_make_word(t) : PrintN("True") : Else : PrintN("False") : EndIf
EndMacro
Procedure.s residue(s$,n.i)
ProcedureReturn Left(s$,Int(n/3)*3)+Mid(s$,Int(n/3)*3+4)
EndProcedure
Procedure.b can_make_word(word$,letters$=#LETTERS)
n=FindString(letters$,Left(word$,1),1,#PB_String_NoCase) If Len(word$) And n : ProcedureReturn can_make_word(Mid(word$,2),residue(letters$,n)) : EndIf If Not Len(word$) : ProcedureReturn #True : Else : ProcedureReturn #False : EndIf
EndProcedure
OpenConsole() test("a") : test("BaRK") : test("BOoK") : test("TREAt") test("cOMMON") : test("SqUAD") : test("COnFUSE") Input()</lang>
- Output:
a = True BaRK = True BOoK = False TREAt = True cOMMON = False SqUAD = True COnFUSE = 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']
R
With recursion
Vectorised function for R which will take a character vector and return a logical vector of equal length with TRUE and FALSE as appropriate for words which can/cannot be made with the blocks.
<lang R>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"))</lang>
- Output:
A BARK BOOK TREAT COMMON SQUAD CONFUSE TRUE TRUE FALSE TRUE FALSE TRUE TRUE
Without recursion
Second version without recursion and giving every unique combination of blocks for each word: <lang R>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"))</lang>
- Output:
$A [,1] [,2] [1,] "AN" "NA" $BARK [,1] [,2] [,3] [,4] [1,] "BO" "AN" "RE" "XK" [2,] "OB" "AN" "RE" "XK" [3,] "BO" "NA" "RE" "XK" [4,] "OB" "NA" "RE" "XK" [5,] "BO" "AN" "ER" "XK" [6,] "OB" "AN" "ER" "XK" [7,] "BO" "NA" "ER" "XK" [8,] "OB" "NA" "ER" "XK" $BOOK character(0) $TREAT [,1] [,2] [,3] [,4] [,5] [1,] "GT" "RE" "ER" "AN" "TG" [2,] "GT" "ER" "RE" "AN" "TG" [3,] "GT" "RE" "ER" "NA" "TG" [4,] "GT" "ER" "RE" "NA" "TG" [5,] "TG" "RE" "ER" "AN" "GT" [6,] "TG" "ER" "RE" "AN" "GT" [7,] "TG" "RE" "ER" "NA" "GT" [8,] "TG" "ER" "RE" "NA" "GT" $COMMON character(0) $SQUAD [,1] [,2] [,3] [,4] [,5] [1,] "FS" "QD" "HU" "AN" "DQ" [2,] "FS" "QD" "HU" "AN" "DQ" [3,] "FS" "QD" "HU" "NA" "DQ" [4,] "FS" "QD" "HU" "NA" "DQ" [5,] "FS" "DQ" "HU" "AN" "QD" [6,] "FS" "DQ" "HU" "AN" "QD" [7,] "FS" "DQ" "HU" "NA" "QD" [8,] "FS" "DQ" "HU" "NA" "QD" $CONFUSE [,1] [,2] [,3] [,4] [,5] [,6] [,7] [1,] "CP" "OB" "NA" "FS" "HU" "FS" "ER" [2,] "PC" "OB" "NA" "FS" "HU" "FS" "ER" [3,] "CP" "BO" "NA" "FS" "HU" "FS" "ER" [4,] "PC" "BO" "NA" "FS" "HU" "FS" "ER" [5,] "CP" "OB" "AN" "FS" "HU" "FS" "ER" [6,] "PC" "OB" "AN" "FS" "HU" "FS" "ER" [7,] "CP" "BO" "AN" "FS" "HU" "FS" "ER" [8,] "PC" "BO" "AN" "FS" "HU" "FS" "ER" [9,] "CP" "OB" "NA" "FS" "HU" "FS" "ER" [10,] "PC" "OB" "NA" "FS" "HU" "FS" "ER" [11,] "CP" "BO" "NA" "FS" "HU" "FS" "ER" [12,] "PC" "BO" "NA" "FS" "HU" "FS" "ER" [13,] "CP" "OB" "AN" "FS" "HU" "FS" "ER" [14,] "PC" "OB" "AN" "FS" "HU" "FS" "ER" [15,] "CP" "BO" "AN" "FS" "HU" "FS" "ER" [16,] "PC" "BO" "AN" "FS" "HU" "FS" "ER" [17,] "CP" "OB" "NA" "FS" "HU" "FS" "RE" [18,] "PC" "OB" "NA" "FS" "HU" "FS" "RE" [19,] "CP" "BO" "NA" "FS" "HU" "FS" "RE" [20,] "PC" "BO" "NA" "FS" "HU" "FS" "RE" [21,] "CP" "OB" "AN" "FS" "HU" "FS" "RE" [22,] "PC" "OB" "AN" "FS" "HU" "FS" "RE" [23,] "CP" "BO" "AN" "FS" "HU" "FS" "RE" [24,] "PC" "BO" "AN" "FS" "HU" "FS" "RE" [25,] "CP" "OB" "NA" "FS" "HU" "FS" "RE" [26,] "PC" "OB" "NA" "FS" "HU" "FS" "RE" [27,] "CP" "BO" "NA" "FS" "HU" "FS" "RE" [28,] "PC" "BO" "NA" "FS" "HU" "FS" "RE" [29,] "CP" "OB" "AN" "FS" "HU" "FS" "RE" [30,] "PC" "OB" "AN" "FS" "HU" "FS" "RE" [31,] "CP" "BO" "AN" "FS" "HU" "FS" "RE" [32,] "PC" "BO" "AN" "FS" "HU" "FS" "RE"
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
RapidQ
<lang vb>dim Blocks as string dim InWord as string
Function CanMakeWord (FInWord as string, FBlocks as string) as integer
dim WIndex as integer, BIndex as integer FBlocks = UCase$(FBlocks) - " " - "," FInWord = UCase$(FInWord) for WIndex = 1 to len(FInWord) BIndex = instr(FBlocks, FInWord[WIndex]) if BIndex then FBlocks = Replace$(FBlocks,"**",iif(BIndex mod 2,BIndex,BIndex-1)) else Result = 0 exit function end if next Result = 1
end function
InWord = "Confuse" Blocks = "BO, XK, DQ, CP, NA, GT, RE, TG, QD, FS, JW, HU, VI, AN, OB, ER, FS, LY, PC, ZM" showmessage "Can make: " + InWord + " = " + iif(CanMakeWord(InWord, Blocks), "True", "False") </lang>
- Output:
Can make: A = TRUE Can make: BARK = TRUE Can make: BOOK = FALSE Can make: TREAT = TRUE Can make: COMMON = FALSE Can make: SQUAD = TRUE Can make: CONFUSE = TRUE
REXX
version 1
<lang rexx>/*REXX program determines if words can be spelt from a pool of toy blocks. */ list= 'A bark bOOk treat common squaD conFuse' /*words can be in 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 a list of seven words*/ call spell word(list,k) /*display if word can be spelt (or not)*/ end /*k*/ /* [↑] tests each word in the list. */
exit /*stick a fork in it, we're all done. */ /*────────────────────────────────────────────────────────────────────────────*/ spell: procedure expose blocks; arg x; p.=0 /*uppercase word to be spelt. */ parse upper var blocks theBlocks; L=length(x) /*uppercase the block letters.*/
/* [↓] try to spell the word.*/ do try=1 for L; z=theBlocks /*use a fresh copy of Z blocks*/ do n=1 for L; y=substr(x,n,1) /*attempt another block letter*/ p.n=pos(y,z,1+p.n); if p.n==0 then iterate try /*not found? Try again.*/ z=overlay(' ',z,p.n) /*mutate block ───► a onesy.*/ do k=1 for words(blocks) /*scrub block pool (not 1s). */ if length(word(z,k))==1 then z=delword(z,k,1) /*single char? Delete.*/ end /*k*/ /* [↑] elide any onesy block.*/ if n==L then leave try /*was the last letter spelt? */ end /*n*/ /* [↑] end of a block attempt*/ end /*try*/ /* [↑] end of "TRY" permute. */
say right(arg(1),30) right(word("can't can", (n==L)+1), 6) 'be spelt.' return</lang> output: [Spelling note: "spelt" is an alternate version of "spelled".]
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.
- Output:
extended
'' 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
Ring
<lang ring>Blocks = [ :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 x in words see '>>> can_make_word("' + upper(x) + '")' + nl if checkword(x,blocks) see "True" + nl else see "False" + nl ok next
func CheckWord Word,Blocks cBlocks = BLocks for x in word Found = false for y = 1 to len(cblocks) if x = cblocks[y][1] or x = cblocks[y][2] cblocks[y] = "--" found = true exit ok next if found = false return false ok next return true</lang>
- Output:
>>> 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
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
Run BASIC
<lang runbasic>blocks$="BO,XK,DQ,CP,NA,GT,RE,TG,QD,FS,JW,HU,VI,AN,OB,ER,FS,LY,PC,ZM" makeWord$ = "A,BARK,BOOK,TREAT,COMMON,SQUAD,Confuse"
b = int((len(blocks$) /3) + 1) dim blk$(b)
for i = 1 to b
blk$(i) = word$(blocks$,i,",")
next i
for i = 1 to len(makeWord$) wrd$ = word$(makeWord$,i,",") dim hit(b) n = 0 if wrd$ = "" then exit for for k = 1 to len(wrd$) w$ = upper$(mid$(wrd$,k,1)) for j = 1 to b if hit(j) = 0 then if w$ = left$(blk$(j),1) or w$ = right$(blk$(j),1) then hit(j) = 1 n = n + 1 exit for end if end if next j next k print wrd$; if n = len(wrd$) then print " True" else print " False" next i</lang>
A True BARK True BOOK False TREAT True COMMON False SQUAD True Confuse True
Rust
This implementation uses a backtracking search. <lang rust>use std::iter::repeat;
fn rec_can_make_word(index: usize, word: &str, blocks: &[&str], used: &mut[bool]) -> bool {
let c = word.chars().nth(index).unwrap().to_uppercase().next().unwrap(); for i in 0..blocks.len() { if !used[i] && blocks[i].chars().any(|s| s == c) { used[i] = true; if index == 0 || rec_can_make_word(index - 1, word, blocks, used) { return true; } used[i] = false; } } false
}
fn can_make_word(word: &str, blocks: &[&str]) -> bool {
return rec_can_make_word(word.chars().count() - 1, word, blocks, &mut repeat(false).take(blocks.len()).collect::<Vec<_>>());
}
fn main() {
let blocks = [("BO"), ("XK"), ("DQ"), ("CP"), ("NA"), ("GT"), ("RE"), ("TG"), ("QD"), ("FS"), ("JW"), ("HU"), ("VI"), ("AN"), ("OB"), ("ER"), ("FS"), ("LY"), ("PC"), ("ZM")]; let words = ["A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"]; for word in &words { println!("{} -> {}", word, can_make_word(word, &blocks)) }
} </lang>
- Output:
A -> true BARK -> true BOOK -> false TREAT -> true COMMON -> false SQUAD -> true CONFUSE -> 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>
Scheme
In R5RS: <lang scheme>(define *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 (exists p? li)
(and (not (null? li)) (or (p? (car li)) (exists p? (cdr li)))))
(define (remove-one x li)
(cond ((null? li) '()) ((equal? (car li) x) (cdr li)) (else (cons (car li) (remove-one x (cdr li))))))
(define (can-make-list? li blocks)
(or (null? li) (exists (lambda (block) (and (member (char-upcase (car li)) block) (can-make-list? (cdr li) (remove-one block blocks)))) blocks)))
(define (can-make-word? word)
(can-make-list? (string->list word) *blocks*))
(define *words*
'("A" "Bark" "book" "TrEaT" "COMMON" "squaD" "CONFUSE"))
(for-each
(lambda (word) (display (if (can-make-word? word) " Can make word: " "Cannot make word: ")) (display word) (newline)) *words*)</lang>
- Output:
Can make word: A Can make word: Bark Cannot make word: book Can make word: TrEaT Cannot make word: COMMON Can make word: squaD Can make word: CONFUSE
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
SequenceL
Recursive Search Version
<lang sequencel>import <Utilities/Conversion.sl>; import <Utilities/Sequence.sl>;
main(args(2)) := let result[i] := args[i] ++ ": " ++ boolToString(can_make_word(args[i], InitBlocks)); in delimit(result, '\n');
InitBlocks := ["BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"];
can_make_word(word(1), blocks(2)) := let choices[i] := i when some(blocks[i] = toUpper(head(word))); blocksAfterChoice[i] := blocks[(1 ... (choices[i] - 1)) ++ ((choices[i] + 1) ... size(blocks))]; in true when size(word) = 0 else false when size(choices) = 0 else some(can_make_word(tail(word), blocksAfterChoice));
toUpper(letter(0)) := let ascii := asciiToInt(letter); in letter when ascii >= 65 and ascii <= 90 else intToAscii(ascii - 32);</lang>
- Output:
cmd:> main.exe A BARK BOOK TREAT COMMON SQUAD CONFUSE "A: true BARK: true BOOK: false TREAT: true COMMON: false SQUAD: true CONFUSE: true"
RegEx Version
<lang sequencel>import <Utilities/Conversion.sl>; import <Utilities/Sequence.sl>; import <RegEx/RegEx.sl>;
main(args(2)) := let result[i] := args[i] ++ ": " ++ boolToString(can_make_word(args[i], InitBlocks)); in delimit(result, '\n');
InitBlocks := "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM";
can_make_word(word(1), blocks(1)) := let regEx := "(\\a" ++ [toUpper(head(word))] ++ "|" ++ [toUpper(head(word))] ++ "\\a)";
newBlocks := replaceFirst(blocks, regEx, ""); in true when size(word) = 0 else false when size(newBlocks) = size(blocks) else can_make_word(tail(word), newBlocks);
toUpper(letter(0)) := let ascii := asciiToInt(letter); in letter when ascii >= 65 and ascii <= 90 else intToAscii(ascii - 32);</lang>
Sidef
<lang ruby>func can_make_word(word, blocks) {
blocks.map! { |b| b.uc.chars.sort.join }.freq!
func(word, blocks) { var char = word.shift var candidates = blocks.keys.grep { |k| 0 <= k.index(char) }
for candidate in candidates { blocks{candidate} <= 0 && next; local blocks{candidate} = (blocks{candidate} - 1); return true if (word.is_empty || __FUNC__(word, blocks)); }
return false; }(word.uc.chars, blocks)
}</lang>
Tests: <lang ruby>var b1 = %w(BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM) var b2 = %w(US TZ AO QA)
var tests = [
["A", true, b1], ["BARK", true, b1], ["BOOK", false, b1], ["TREAT", true, b1], ["COMMON", false, b1], ["SQUAD", true, b1], ["CONFUSE", true, b1], ["auto", true, b2],
];
tests.each { |t|
var bool = can_make_word(t[0], t[2]); say ("%7s -> %s" % (t[0], bool)); assert(bool == t[1])
}</lang>
- Output:
A -> true BARK -> true BOOK -> false TREAT -> true COMMON -> false SQUAD -> true CONFUSE -> true auto -> true
Smalltalk
Recursive solution. Tested in Pharo. <lang smalltalk> ABCPuzzle>>test #('A' 'BARK' 'BOOK' 'TreaT' 'COMMON' 'sQUAD' 'CONFuSE') do: [ :each | Transcript crShow: each, ': ', (self solveFor: each) asString ]
ABCPuzzle>>solveFor: letters | blocks | blocks := #('BO' 'XK' 'DQ' 'CP' 'NA' 'GT' 'RE' 'TG' 'QD' 'FS' 'JW' 'HU' 'VI' 'AN' 'OB' 'ER' 'FS' 'LY' 'PC' 'ZM'). ^ self solveFor: letters asUppercase with: blocks asOrderedCollection
ABCPuzzle>>solveFor: letters with: blocks | l ldash matches | letters isEmpty ifTrue: [ ^ true ]. l := letters first. ldash := letters allButFirst. matches := blocks select: [ :b | b includes: l ]. matches isEmpty ifTrue: [ ^ false ]. matches do: [ :m | | bdash | bdash := blocks copy. bdash remove: m. (self solveFor: ldash with: bdash) ifTrue: [ ^ true ] ]. ^ false </lang>
- Output:
ABCPuzzle new test A: true BARK: true BOOK: false TreaT: true COMMON: false sQUAD: true CONFuSE: true
Swift
<lang Swift>import Foundation
func Blockable(str: String) -> Bool {
var blocks = [ "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 = ""
for char: Character in strUp { var CharString: String = ""; CharString.append(char) for j in 0..<blocks.count { if blocks[j].hasPrefix(CharString) || blocks[j].hasSuffix(CharString) { final.append(char) blocks[j] = "" break } } }
return final == strUp
}
func CanOrNot(can: Bool) -> String {
return can ? "can" : "cannot"
}
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 "A" -> A ;; tuples -- turn string into 1-element tuples: "ABC" -> ("A" "B" "C") ;; 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 (tuples 1 (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
UNIX Shell
<lang bash>can_build_word() {
if $1 ; then can_build_word_rec "$1" BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM else return 1 fi
}
can_build_word_rec() {
-z $1 && return 0
local -u word=$1 # uppercase the first parameter shift local blocks=("$@")
# see if we have a block for the first letter local letter=${word:0:1} indices=() i for (( i=0; i<${#blocks[@]}; i++ )); do if [[ ${blocks[i]} == *$letter* ]]; then indices+=($i) fi done (( ${#indices[@]} == 0 )) && return 1
local tmp for i in ${indices[@]}; do tmp=( "${blocks[@]}" ) unset "tmp[$i]" can_build_word_rec "${word:1}" "${tmp[@]}" && return 0 done
return 1
}
words=( "" A BARK Book treat COMMON Squad confuse ) for word in "${words[@]}"; do
can_build_word "$word" "${blocks[@]}" && ans=yes || ans=no printf "%s\t%s\n" "$word" $ans
done</lang>
- Output:
no A yes BARK yes Book no treat yes COMMON no Squad yes confuse yes
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.idx;
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
- Programming Tasks
- Solutions by Programming Task
- Acurity Architect
- Ada
- ALGOL 68
- ALGOL W
- AppleScript
- AutoHotkey
- Batch File
- BBC BASIC
- Bracmat
- C
- C++
- C sharp
- Clojure
- CoffeeScript
- Common Lisp
- D
- Delphi
- Elixir
- Erlang
- ERRE
- Euphoria
- FBSL
- Fortran
- Go
- Groovy
- Harbour
- Haskell
- Icon
- Unicon
- J
- Java
- JavaScript
- Jq
- Julia
- Kotlin
- Logo
- Lua
- Mathematica
- Wolfram Language
- MATLAB
- MAXScript
- Nim
- Oberon-2
- Objeck
- OCaml
- Oforth
- OpenEdge/Progress
- Perl
- Perl 6
- Phix
- PHP
- PicoLisp
- PL/I
- PowerBASIC
- PowerShell
- Prolog
- PureBasic
- Python
- R
- Racket
- RapidQ
- REXX
- Ring
- Ruby
- Run BASIC
- Rust
- Scala
- Scheme
- Seed7
- SequenceL
- Sidef
- Smalltalk
- Swift
- Tcl
- TUSCRIPT
- TXR
- UNIX Shell
- Zkl