ABC problem: Difference between revisions
(add UNIX Shell) |
(Added ABC Game (DOS Batch Language Version)) |
||
Line 223: | Line 223: | ||
SQUAD - 1 |
SQUAD - 1 |
||
CONFUSE - 1</pre> |
CONFUSE - 1</pre> |
||
=={{header|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> |
|||
=={{header|BBC BASIC}}== |
=={{header|BBC BASIC}}== |
Revision as of 01:55, 3 October 2014
You are encouraged to solve this task according to the task description, using any language you may know.
You are given a collection of ABC blocks. Just like the ones you had when you were a kid. There are twenty blocks with two letters on each block. You are guaranteed to have a complete alphabet amongst all sides of the blocks. The sample blocks are:
- ((B O)
- (X K)
- (D Q)
- (C P)
- (N A)
- (G T)
- (R E)
- (T G)
- (Q D)
- (F S)
- (J W)
- (H U)
- (V I)
- (A N)
- (O B)
- (E R)
- (F S)
- (L Y)
- (P C)
- (Z M))
The goal of this task is to write a function that takes a string and can determine whether you can spell the word with the given collection of blocks. The rules are simple:
- Once a letter on a block is used that block cannot be used again
- The function should be case-insensitive
- Show your output on this page for the following words:
- Example
<lang python>
>>> can_make_word("A") True >>> can_make_word("BARK") True >>> can_make_word("BOOK") False >>> can_make_word("TREAT") True >>> can_make_word("COMMON") False >>> can_make_word("SQUAD") True >>> can_make_word("CONFUSE") True
</lang>
Ada
Build with gnatchop abc.ada; gnatmake abc_problem
<lang ada>with Ada.Characters.Handling; use Ada.Characters.Handling;
package Abc is
type Block_Faces is array(1..2) of Character; type Block_List is array(positive range <>) of Block_Faces; function Can_Make_Word(W: String; Blocks: Block_List) return Boolean;
end Abc;
package body Abc is
function Can_Make_Word(W: String; Blocks: Block_List) return Boolean is
Used : array(Blocks'Range) of Boolean := (Others => False); subtype wIndex is Integer range W'First..W'Last; wPos : wIndex;
begin
if W'Length = 0 then return True; end if; wPos := W'First; while True loop declare C : Character := To_Upper(W(wPos)); X : constant wIndex := wPos; begin for I in Blocks'Range loop if (not Used(I)) then if C = To_Upper(Blocks(I)(1)) or C = To_Upper(Blocks(I)(2)) then Used(I) := True; if wPos = W'Last then return True; end if; wPos := wIndex'Succ(wPos); exit; end if; end if; end loop; if X = wPos then return False; end if; end; end loop; return False;
end Can_Make_Word;
end Abc;
with Ada.Text_IO, Ada.Strings.Unbounded, Abc; use Ada.Text_IO, Ada.Strings.Unbounded, Abc;
procedure Abc_Problem is
Blocks : Block_List := ( ('B','O'), ('X','K'), ('D','Q'), ('C','P') , ('N','A'), ('G','T'), ('R','E'), ('T','G') , ('Q','D'), ('F','S'), ('J','W'), ('H','U') , ('V','I'), ('A','N'), ('O','B'), ('E','R') , ('F','S'), ('L','Y'), ('P','C'), ('Z','M') ); function "+" (S : String) return Unbounded_String renames To_Unbounded_String; words : array(positive range <>) of Unbounded_String := ( +"A" , +"BARK" , +"BOOK" , +"TREAT" , +"COMMON" , +"SQUAD" , +"CONFUSE" -- Border cases: -- , +"CONFUSE2" -- , +"" );
begin
for I in words'Range loop Put_Line ( To_String(words(I)) & ": " & Boolean'Image(Can_Make_Word(To_String(words(I)),Blocks)) ); end loop;
end Abc_Problem; </lang>
Output:
A: TRUE BARK: TRUE BOOK: FALSE TREAT: TRUE COMMON: FALSE SQUAD: TRUE CONFUSE: TRUE
AutoHotkey
Function <lang autohotkey>isWordPossible(blocks, word){ o := {} loop, parse, blocks, `n, `r o.Insert(A_LoopField) loop, parse, word if !(r := isWordPossible_contains(o, A_LoopField, word)) return 0 return 1 } isWordPossible_contains(byref o, letter, word){ loop 2 { for k,v in o if Instr(v,letter) { StringReplace, op, v,% letter if RegExMatch(op, "[" word "]") sap := k else added := 1 , sap := k if added return "1" o.remove(sap) } added := 1 } }</lang>
Test Input (as per question) <lang autohotkey>blocks := " ( BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM )"
wordlist := " ( A BARK BOOK TREAT COMMON SQUAD CONFUSE )"
loop, parse, wordlist, `n out .= A_LoopField " - " isWordPossible(blocks, A_LoopField) "`n" msgbox % out</lang>
Output
A - 1 BARK - 1 BOOK - 0 TREAT - 1 COMMON - 0 SQUAD - 1 CONFUSE - 1
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#
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
Common Lisp
<lang lisp> (defun word-possible-p (word blocks)
(cond ((= (length word) 0) t) ((null blocks) nil) (t (let* ((c (aref word 0)) (bs (remove-if-not #'(lambda (b) (find c b :test #'char-equal)) blocks))) (some #'identity (loop for b in bs collect (word-possible-p (subseq word 1) (remove b blocks))))))))</lang>
- Output:
> (defparameter *blocks* '("BO" "XK" "DQ" "CP" "NA" "GT" "RE" "TG" "QD" "FS" "JW" "HU" "VI" "AN" "OB" "ER" "FS" "LY" "PC" "ZM")) > (dolist (w '("" "A" "bArk" "BOOK" "trEAt" "CoMmoN" "squad" "conFUse")) (format t "~s is possible: ~a~%" w (word-possible-p w *blocks*))) "" is possible: T "A" is possible: T "bArk" is possible: T "BOOK" is possible: NIL "trEAt" is possible: T "CoMmoN" is possible: NIL "squad" is possible: T "conFUse" is possible: T NIL > (word-possible-p "abba" '("AB" "AB" "AC" "AC")) T
D
A simple greedy algorithm is enough for the given sequence of blocks. canMakeWord is true on an empty word because you can compose it using zero blocks. <lang d>import std.stdio, std.algorithm, std.string;
bool canMakeWord(in string word, in string[] blocks) pure /*nothrow*/ {
auto bs = blocks.dup; outer: foreach (immutable ch; word.toUpper) { foreach (immutable block; bs) if (block.canFind(ch)) { bs = bs.remove(bs.countUntil(block)); continue outer; } return false; } return true;
}
void main() {
immutable blocks = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM".split;
foreach (word; "" ~ "A BARK BoOK TrEAT COmMoN SQUAD conFUsE".split) writefln(`"%s" %s`, word, canMakeWord(word, blocks));
}</lang>
- Output:
"" true "A" true "BARK" true "BoOK" false "TrEAT" true "COmMoN" false "SQUAD" true "conFUsE" true
Recursive Version
This version is able to find the solution for the word "abba" given the blocks AB AB AC AC.
<lang d>import std.stdio, std.ascii, std.algorithm, std.array;
alias Block = char[2];
// Modifies the order of the given blocks. bool canMakeWord(Block[] blocks, in string word) pure nothrow in {
assert(blocks.all!(w => w[].all!isAlpha)); assert(word.all!isAlpha);
} body {
if (word.empty) return true;
immutable c = word[0].toUpper; foreach (ref b; blocks) { if (b[0].toUpper != c && b[1].toUpper != c) continue; blocks[0].swap(b); if (blocks[1 .. $].canMakeWord(word[1 .. $])) return true; blocks[0].swap(b); }
return false;
}
void main() {
enum Block[] blocks = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM".split;
foreach (w; "" ~ "A BARK BoOK TrEAT COmMoN SQUAD conFUsE".split) writefln(`"%s" %s`, w, blocks.canMakeWord(w));
// Extra test. Block[] blocks2 = ["AB", "AB", "AC", "AC"]; immutable word = "abba"; writefln(`"%s" %s`, word, blocks2.canMakeWord(word));
}</lang>
- Output:
"" true "A" true "BARK" true "BoOK" false "TrEAT" true "COmMoN" false "SQUAD" true "conFUsE" true "abba" true
Alternative Recursive Version
This version doesn't shuffle the input blocks, but it's more complex and it allocates an array of indexes. <lang d>import std.stdio, std.ascii, std.algorithm, std.array, std.range;
alias Block = char[2];
bool canMakeWord(immutable Block[] blocks, in string word) pure nothrow in {
assert(blocks.all!(w => w[].all!isAlpha)); assert(word.all!isAlpha);
} body {
bool inner(size_t[] indexes, in string w) pure nothrow { if (w.empty) return true;
immutable c = w[0].toUpper; foreach (ref idx; indexes) { if (blocks[idx][0].toUpper != c && blocks[idx][1].toUpper != c) continue; indexes[0].swap(idx); if (inner(indexes[1 .. $], w[1 .. $])) return true; indexes[0].swap(idx); }
return false; }
return inner(blocks.length.iota.array, word);
}
void main() {
enum Block[] blocks = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM".split;
foreach (w; "" ~ "A BARK BoOK TrEAT COmMoN SQUAD conFUsE".split) writefln(`"%s" %s`, w, blocks.canMakeWord(w));
// Extra test. immutable Block[] blocks2 = ["AB", "AB", "AC", "AC"]; immutable word = "abba"; writefln(`"%s" %s`, word, blocks2.canMakeWord(word));
}</lang> The output is the same.
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
Harbour
Harbour Project implements a cross-platform Clipper/xBase compiler. <lang visualfoxpro>PROCEDURE Main()
LOCAL cStr
FOR EACH cStr IN { "A", "BARK", "BooK", "TrEaT", "comMON", "sQuAd", "Confuse" } ? PadL( cStr, 10 ), iif( Blockable( cStr ), "can", "cannot" ), "be spelled with blocks." NEXT
RETURN
STATIC FUNCTION Blockable( cStr )
LOCAL blocks := { ; "BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", ; "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM" }
LOCAL cFinal := "" LOCAL i, j
cStr := Upper( cStr )
FOR i := 1 TO Len( cStr ) FOR EACH j IN blocks IF SubStr( cStr, i, 1 ) $ j cFinal += SubStr( cStr, i, 1 ) j := "" EXIT ENDIF NEXT NEXT
RETURN cFinal == cStr</lang>
Output
A can be spelled with blocks. BARK can be spelled with blocks. BooK cannot be spelled with blocks. TrEaT can be spelled with blocks. comMON cannot be spelled with blocks. sQuAd can be spelled with blocks. Confuse can be spelled with blocks.
Haskell
The following function returns a list of all the solutions. Since Haskell is lazy, testing whether the list is null will only do the minimal amount of work necessary to determine whether a solution exists. <lang haskell>import Data.List (delete) import Data.Char (toUpper)
-- returns list of all solutions, each solution being a list of blocks abc :: (Eq a) => a -> [a] -> [[[a]]] abc _ [] = [[]] abc blocks (c:cs) = [b:ans | b <- blocks, c `elem` b,
ans <- abc (delete b blocks) cs]
blocks = ["BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"]
main :: IO () main = mapM_ (\w -> print (w, not . null $ abc blocks (map toUpper w)))
["", "A", "BARK", "BoOK", "TrEAT", "COmMoN", "SQUAD", "conFUsE"]</lang>
- Output:
("",True) ("A",True) ("BARK",True) ("BoOK",False) ("TrEAT",True) ("COmMoN",False) ("SQUAD",True) ("conFUsE",True)
Icon and Unicon
Works in both languages: <lang unicon>procedure main(A)
blocks := ["bo","xk","dq","cp","na","gt","re","tg","qd","fs", "jw","hu","vi","an","ob","er","fs","ly","pc","zm",&null] every write("\"",word := !A,"\" ",checkSpell(map(word),blocks)," with blocks.")
end
procedure checkSpell(w,blocks)
blks := copy(blocks) w ? return if canMakeWord(blks) then "can be spelled" else "can not be spelled"
end
procedure canMakeWord(blks)
c := move(1) | return if /blks[1] then fail every i := 1 to *blks do { if /blks[i] then (move(-1),fail) if c == !blks[i] then { blks[1] :=: blks[i] if canMakeWord(blks[2:0]) then return blks[1] :=: blks[i] } }
end</lang>
Sample run:
->abc "" A BARK BOOK TREAT COMMON SQUAD CONFUSE "" can be spelled with blocks. "A" can be spelled with blocks. "BARK" can be spelled with blocks. "BOOK" can not be spelled with blocks. "TREAT" can be spelled with blocks. "COMMON" can not be spelled with blocks. "SQUAD" can be spelled with blocks. "CONFUSE" can be spelled with blocks. ->
J
Solution: <lang j>reduce=: verb define
'rows cols'=. i.&.> $y for_c. cols do. r=. 1 i.~ c {"1 y NB. row idx of first 1 in col if. r = #rows do. continue. end. y=. 0 (<((r+1)}.rows);c) } y NB. zero rest of col y=. 0 (<(r;(c+1)}.cols)) } y NB. zero rest of row end.
)
abc=: *./@(+./)@reduce@(e."1~ ,)&toupper :: 0:</lang> Examples: <lang j> Blocks=: ];._2 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM '
ExampleWords=: <;._2 'A BaRK BOoK tREaT COmMOn SqUAD CoNfuSE '
Blocks&abc &> ExampleWords
1 1 0 1 0 1 1
require 'format/printf' '%10s %s' printf (dquote ; 'FT' {~ Blocks&abc) &> ExampleWords "A" T "BaRK" T "BOoK" F "tREaT" T "COmMOn" F "SqUAD" T "CoNfuSE" T</lang>
Tacit version <lang j>delElem=: {~<@<@< uppc=:(-32*96&<*.123&>)&.(3&u:) reduc=: ] delElem 1 i.~e."0 1</lang>
Output <lang j> (,.[: a:&~:&.> Blocks&(reduc L:0/ :: (a:"_)@(<"0@],<@[))&.>@(uppc&.(;: inv))) ExampleWords ┌───────┬─┐ │A │1│ ├───────┼─┤ │BaRK │1│ ├───────┼─┤ │BOoK │0│ ├───────┼─┤ │tREaT │1│ ├───────┼─┤ │COmMOn │0│ ├───────┼─┤ │SqUAD │1│ ├───────┼─┤ │CoNfuSE│1│ └───────┴─┘</lang>
Alternative Implementation
Another approach might be:
<lang J>Blocks=: >;:'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM ' ExampleWords=: ;: 'A BaRK BOoK tREaT COmMOn SqUAD CoNfuSE '
canform=:4 :0
word=: toupper y need=: #/.~ word,word relevant=: (x +./@e."1 word) # x candidates=: word,"1>,{{relevant +./(((#need){. #/.~)"1 candidates) */ .>:need
)</lang>
Example use:
<lang J> Blocks canform 0{::ExampleWords 1
Blocks canform 1{::ExampleWords
1
Blocks canform 2{::ExampleWords
0
Blocks canform 3{::ExampleWords
1
Blocks canform 4{::ExampleWords
0
Blocks canform 5{::ExampleWords
1
Blocks canform 6{::ExampleWords
1</lang>
Explanation:
We only need to consider blocks which contain letters in common with a normalized (upper case) version of the desired word. But we do need to consider all possible combinations of letters from those blocks (see talk page discussion of words like 'ABBA' for more on this issue).
We can classify possibilities by counting how many of each letter occur. If a candidate has at least as many of the required letters as a test case constructed from the word itself, it's a valid candidate.
Java
<lang java5>import java.util.Arrays;
public class ABC{ private static void swap(int i, int j, Object... arr){ Object tmp = arr[i]; arr[i] = arr[j]; arr[j] = tmp; }
public static boolean canMakeWord(String word, String... blocks) { if(word.length() == 0) return true;
char c = Character.toUpperCase(word.charAt(0)); for(int i = 0; i < blocks.length; i++) { String b = blocks[i]; if(Character.toUpperCase(b.charAt(0)) != c && Character.toUpperCase(b.charAt(1)) != c) continue; swap(0, i, blocks); if(canMakeWord(word.substring(1), Arrays.copyOfRange(blocks, 1, blocks.length))) return true; swap(0, i, blocks); }
return false; }
public static void main(String[] args){ String[] blocks = {"BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"};
System.out.println("\"\": " + canMakeWord("", blocks)); System.out.println("A: " + canMakeWord("A", blocks)); System.out.println("BARK: " + canMakeWord("BARK", blocks)); System.out.println("book: " + canMakeWord("book", blocks)); System.out.println("treat: " + canMakeWord("treat", blocks)); System.out.println("COMMON: " + canMakeWord("COMMON", blocks)); System.out.println("SQuAd: " + canMakeWord("SQuAd", blocks)); System.out.println("CONFUSE: " + canMakeWord("CONFUSE", blocks));
} }</lang>
- Output:
"": true A: true BARK: true book: false treat: true COMMON: false SQuAd: true CONFUSE: true
JavaScript
ES6
<lang javascript>let characters = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM"; let blocks = characters.split(" ").map(pair => pair.split(""));
function isWordPossible(word) {
var letters = [...word.toUpperCase()]; var length = letters.length; var copy = new Set(blocks);
for (let letter of letters) { for (let block of copy) { let index = block.indexOf(letter); if (index !== -1) { length--; copy.delete(block); break; } }
} return !length;
}
[
"A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"
].forEach(word => console.log(`${word}: ${isWordPossible(word)}`)); </lang>
Result:
A: true BARK: true BOOK: false TREAT: true COMMON: false SQUAD: true CONFUSE: true
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 = 1:length(list) str[end] in list[i] && any([abc(str[1:end-1], deleteat!(copy(list), i))]) && return true end false
end</lang>
- Output:
julia> let test = ["A", "BARK","BOOK","TREAT","COMMON","SQUAD","CONFUSE"], list = {"BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS", "JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"} for str in test @printf("%-8s | %s\n", str, abc(str, list)) end end A | true BARK | true BOOK | false TREAT | true COMMON | false SQUAD | true CONFUSE | true
Mathematica
<lang Mathematica> blocks=Partition[Characters[ToLowerCase["BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"]],2]; ClearAll[DoStep,ABCBlockQ] DoStep[chars_List,blcks_List,chosen_List]:=Module[{opts},
If[chars=!={}, opts=Select[blcks,MemberQ[#,First[chars]]&]; {Rest[chars],DeleteCases[blcks,#,1,1],Append[chosen,#]}&/@opts , Template:Chars,blcks,chosen ]
] DoStep[opts_List]:=Flatten[DoStep@@@opts,1] ABCBlockQ[str_String]:=(FixedPoint[DoStep,{{Characters[ToLowerCase[str]],blocks,{}}}]=!={}) </lang>
- Output:
ABCBlockQ["A"] ABCBlockQ["BARK"] ABCBlockQ["BOOK"] ABCBlockQ["TREAT"] ABCBlockQ["COMMON"] ABCBlockQ["SQUAD"] ABCBlockQ["CONFUSE"] True True False True False True True
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.
Nimrod
<lang nimrod>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
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)
Perl
Recursive solution that can handle characters appearing on different blocks: <lang perl>#!/usr/bin/perl use warnings; use strict;
sub can_make_word {
my ($word, @blocks) = @_; $_ = uc join q(), sort split // for @blocks; my %blocks; $blocks{$_}++ for @blocks; return _can_make_word(uc $word, %blocks)
}
sub _can_make_word {
my ($word, %blocks) = @_; my $char = substr $word, 0, 1, q();
my @candidates = grep 0 <= index($_, $char), keys %blocks; for my $candidate (@candidates) { next if $blocks{$candidate} <= 0; local $blocks{$candidate} = $blocks{$candidate} - 1; return 1 if q() eq $word or _can_make_word($word, %blocks); } return
}</lang>
Testing: <lang perl>use Test::More tests => 8; my @blocks1 = qw(BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM); is(can_make_word("A", @blocks1), 1); is(can_make_word("BARK", @blocks1), 1); is(can_make_word("BOOK", @blocks1), undef); is(can_make_word("TREAT", @blocks1), 1); is(can_make_word("COMMON", @blocks1), undef); is(can_make_word("SQUAD", @blocks1), 1); is(can_make_word("CONFUSE", @blocks1), 1); my @blocks2 = qw(US TZ AO QA); is(can_make_word('auto', @blocks2), 1); </lang>
Perl 6
Blocks are stored as precompiled regexes. We do an initial pass on the blockset to include in the list only those regexes that match somewhere in the current word. Conveniently, regexes scan the word for us. <lang perl6>multi can-spell-word(Str $word, @blocks) {
my @regex = @blocks.map({ EVAL "/{.comb.join('|')}/" }).grep: { .ACCEPTS($word.uc) } can-spell-word $word.uc.comb, @regex;
}
multi can-spell-word([$head,*@tail], @regex) {
for @regex -> $re { if $head ~~ $re { return True unless @tail; return False if @regex == 1; return True if can-spell-word @tail, @regex.grep: * !=== $re; } } False;
}
my @b = <BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM>;
for <A BaRK BOoK tREaT COmMOn SqUAD CoNfuSE> {
say "$_ &can-spell-word($_, @b)";
}</lang>
- Output:
A True BaRK True BOoK False tREaT True COmMOn False SqUAD True CoNfuSE True
PHP
<lang PHP> <?php $words = array("A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "Confuse");
function canMakeWord($word) {
$word = strtoupper($word); $blocks = array( "BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM", );
foreach (str_split($word) as $char) { foreach ($blocks as $k => $block) { if (strpos($block, $char) !== FALSE) { unset($blocks[$k]); continue(2); } } return false; } return true;
}
foreach ($words as $word) {
echo $word.': '; echo canMakeWord($word) ? "True" : "False"; echo "\r\n";
}</lang> Output:
A: True BARK: True BOOK: False TREAT: True COMMON: False SQUAD: True Confuse: True
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
Prolog
Works with SWI-Prolog 6.5.3
<lang Prolog>abc_problem :- maplist(abc_problem, [, 'A', bark, bOOk, treAT, 'COmmon', sQuaD, 'CONFUSE']).
abc_problem(Word) :-
L = [[b,o],[x,k],[d,q],[c,p],[n,a],[g,t],[r,e],[t,g],[q,d],[f,s],
[j,w],[h,u],[v,i],[a,n],[o,b],[e,r],[f,s],[l,y],[p,c],[z,m]],
( abc_problem(L, Word) -> format('~w OK~n', [Word]) ; format('~w KO~n', [Word])).
abc_problem(L, Word) :- atom_chars(Word, C_Words), maplist(downcase_atom, C_Words, D_Words), can_makeword(L, D_Words).
can_makeword(_L, []).
can_makeword(L, [H | T]) :- ( select([H, _], L, L1); select([_, H], L, L1)), can_makeword(L1, T). </lang> Output :
?- abc_problem. OK A OK bark OK bOOk KO treAT OK COmmon KO sQuaD OK CONFUSE OK true.
Python
Python: Iterative, with tests
<lang python> blocks = [("B", "O"),
("X", "K"), ("D", "Q"), ("C", "P"), ("N", "A"), ("G", "T"), ("R", "E"), ("T", "G"), ("Q", "D"), ("F", "S"), ("J", "W"), ("H", "U"), ("V", "I"), ("A", "N"), ("O", "B"), ("E", "R"), ("F", "S"), ("L", "Y"), ("P", "C"), ("Z", "M")]
def can_make_word(word, block_collection=blocks):
""" Return True if `word` can be made from the blocks in `block_collection`.
>>> can_make_word("") False >>> can_make_word("a") True >>> can_make_word("bark") True >>> can_make_word("book") False >>> can_make_word("treat") True >>> can_make_word("common") False >>> can_make_word("squad") True >>> can_make_word("coNFused") True """ if not word: return False
blocks_remaining = block_collection[:] for char in word.upper(): for block in blocks_remaining: if char in block: blocks_remaining.remove(block) break else: return False return True
if __name__ == "__main__":
import doctest doctest.testmod() print(", ".join("'%s': %s" % (w, can_make_word(w)) for w in ["", "a", "baRk", "booK", "treat", "COMMON", "squad", "Confused"]))
</lang>
- Output:
'': False, 'a': True, 'baRk': True, 'booK': False, 'treat': True, 'COMMON': False, 'squad': True, 'Confused': True
Python: Recursive
<lang python>BLOCKS = 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM'.split()
def _abc(word, blocks):
for i, ch in enumerate(word): for blk in (b for b in blocks if ch in b): whatsleft = word[i + 1:] blksleft = blocks[:] blksleft.remove(blk) if not whatsleft: return True, blksleft if not blksleft: return False, blksleft ans, blksleft = _abc(whatsleft, blksleft) if ans: return ans, blksleft else: break return False, blocks
def abc(word, blocks=BLOCKS):
return _abc(word.upper(), blocks)[0]
if __name__ == '__main__':
for word in [] + 'A BARK BoOK TrEAT COmMoN SQUAD conFUsE'.split(): print('Can we spell %9r? %r' % (word, abc(word)))</lang>
- Output:
Can we spell ''? False Can we spell 'A'? True Can we spell 'BARK'? True Can we spell 'BoOK'? False Can we spell 'TrEAT'? True Can we spell 'COmMoN'? False Can we spell 'SQUAD'? True Can we spell 'conFUsE'? True
Python: Recursive, telling how
<lang python>def mkword(w, b):
if not w: return []
c,w = w[0],w[1:] for i in range(len(b)): if c in b[i]: m = mkword(w, b[0:i] + b[i+1:]) if m != None: return [b[i]] + m
def abc(w, blk):
return mkword(w.upper(), [a.upper() for a in blk])
blocks = 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM'.split()
for w in ", A, bark, book, treat, common, SQUAD, conFUsEd".split(', '):
print '\ + w + '\ + ' ->', abc(w, blocks)</lang>
- Output:
Note the case of empty list returned for empty string; whether it means true or false is up to you.
'' -> [] 'A' -> ['NA'] 'bark' -> ['BO', 'NA', 'RE', 'XK'] 'book' -> None 'treat' -> ['GT', 'RE', 'ER', 'NA', 'TG'] 'common' -> None 'SQUAD' -> ['FS', 'DQ', 'HU', 'NA', 'QD'] 'conFUsEd' -> ['CP', 'BO', 'NA', 'FS', 'HU', 'FS', 'RE', 'DQ']
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
REXX
version 1
<lang rexx>/*REXX pgm checks if a word list can be spelt from a pool of toy blocks.*/ list = 'A bark bOOk treat common squaD conFuse' /*words can be any case.*/ blocks = 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM'
do k=1 for words(list) /*traipse through list of words. */ call spell word(list,k) /*show if word be spelt (or not).*/ end /*k*/ /* [↑] tests each word in list. */
exit /*stick a fork in it, we're done.*/ /*──────────────────────────────────SPELL subroutine────────────────────*/ spell: procedure expose blocks; parse arg ox . 1 x . /*get word to spell*/ z=blocks; upper x z; oz=z; p.=0; L=length(x) /*uppercase the blocks. */
/* [↓] try to spell it.*/ do try=1 for L; z=oz /*use a fresh copy of Z.*/ do n=1 for L; y=substr(x,n,1) /*attempt another letter*/ p.n=pos(y,z,1+p.n); if p.n==0 then iterate try /*¬ found? Try again.*/ z=overlay(' ',z,p.n) /*mutate block──► onesy.*/ do k=1 for words(blocks) /*scrub block pool (¬1s)*/ if length(word(z,k))==1 then z=delword(z,k,1) /*1 char? Delete.*/ end /*k*/ /* [↑] elide any onesy.*/ if n==L then leave try /*the last letter spelt?*/ end /*n*/ /* [↑] end of an attempt*/ end /*try*/ /* [↑] end TRY permute.*/
say right(ox,30) right(word("can't can", (n==L)+1), 6) 'be spelt.' return n==L /*also, return the flag.*/</lang> output
A can be spelt. bark can be spelt. bOOk can't be spelt. treat can be spelt. common can't be spelt. squaD can be spelt. conFuse can be spelt.
version 2
<lang rexx>/* REXX ---------------------------------------------------------------
- 10.01.2014 Walter Pachl counts the number of possible ways
- 12.01.2014 corrected date and output
- --------------------------------------------------------------------*/
show=(arg(1)<>) blocks = 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM' list = '$ A baRk bOOk trEat coMMon squaD conFuse' list=translate(list) Do i=1 To words(blocks)
blkn.i=word(blocks,i)'-'i blk.i=word(blocks,i) End
w.= wlen=0 Do i=1 To words(list)
w.i=word(list,i) wlen=max(wlen,length(w.i)) End
Do wi=0 To words(list)
word = w.wi ways=0 poss.=0 lw=length(word) cannot=0 Do i=1 To lw /* loop over the characters */ c=substr(word,i,1) /* the current character */ Do j=1 To words(blocks) /* loop over blocks */ blk=word(blocks,j) If pos(c,blk)>0 Then Do /* block can be used in this position */ z=poss.i.0+1 poss.i.z=j poss.i.0=z /* number of possible blocks for pos i */ End End If poss.i.0=0 Then Do cannot=1 Leave i End End
If cannot=0 Then Do /* no prohibitive character */ s.=0 Do j=1 To poss.1.0 /* build possible strings for char 1 */ z=s.1.0+1 s.1.z=poss.1.j s.1.0=z End Do i=2 To lw /* build possible strings for chars 1 to i */ ii=i-1 Do j=1 To poss.i.0 Do k=1 To s.ii.0 z=s.i.0+1 s.i.z=s.ii.k poss.i.j s.i.0=z End End End Do p=1 To s.lw.0 /* loop through all possible strings */ v=valid(s.lw.p) /* test if the string is valid*/ If v Then Do /* it is */ ways=ways+1 /* increment number of ways */ way.ways= /* and store the string's blocks */ Do ii=1 To lw z=word(s.lw.p,ii) way.ways=way.ways blk.z End End End End
/*---------------------------------------------------------------------
- now show the result
- --------------------------------------------------------------------*/
ol=left('word',wlen+2) Select When ways=0 Then ol=ol 'cannot be spelt' When ways=1 Then ol=ol 'can be spelt' Otherwise ol=ol 'can be spelt in' ways 'ways' End Say ol'.' If show Then Do Do wj=1 To ways Say copies(' ',10) way.wj End End End
Exit
valid: Procedure /*---------------------------------------------------------------------
- Check if the same block is used more than once -> 0
- Else: the combination is valid
- --------------------------------------------------------------------*/
Parse Arg list used.=0 Do i=1 To words(list) w=word(list,i) If used.w Then Return 0 used.w=1 End Return 1</lang>
output
'' cannot be spelt. '$' cannot be spelt. 'A' can be spelt in 2 ways. 'BARK' can be spelt in 8 ways. 'BOOK' cannot be spelt. 'TREAT' can be spelt in 8 ways. 'COMMON cannot be spelt. 'SQUAD' can be spelt in 8 ways. 'CONFUS can be spelt in 32 ways.
extended output
'' cannot be spelt. '$' cannot be spelt. 'A' can be spelt in 2 ways. NA AN 'BARK' can be spelt in 8 ways. BO NA RE XK OB NA RE XK BO AN RE XK OB AN RE XK BO NA ER XK OB NA ER XK BO AN ER XK OB AN ER XK 'BOOK' cannot be spelt. 'TREAT' can be spelt in 8 ways. TG ER RE NA GT TG RE ER NA GT TG ER RE AN GT TG RE ER AN GT GT ER RE NA TG GT RE ER NA TG GT ER RE AN TG GT RE ER AN TG 'COMMON' cannot be spelt. 'SQUAD' can be spelt in 8 ways. FS QD HU NA DQ FS QD HU NA DQ FS QD HU AN DQ FS QD HU AN DQ FS DQ HU NA QD FS DQ HU NA QD FS DQ HU AN QD FS DQ HU AN QD 'CONFUSE' can be spelt in 32 ways. CP BO NA FS HU FS RE PC BO NA FS HU FS RE CP OB NA FS HU FS RE PC OB NA FS HU FS RE CP BO AN FS HU FS RE PC BO AN FS HU FS RE CP OB AN FS HU FS RE PC OB AN FS HU FS RE CP BO NA FS HU FS RE PC BO NA FS HU FS RE CP OB NA FS HU FS RE PC OB NA FS HU FS RE CP BO AN FS HU FS RE PC BO AN FS HU FS RE CP OB AN FS HU FS RE PC OB AN FS HU FS RE CP BO NA FS HU FS ER PC BO NA FS HU FS ER CP OB NA FS HU FS ER PC OB NA FS HU FS ER CP BO AN FS HU FS ER PC BO AN FS HU FS ER CP OB AN FS HU FS ER PC OB AN FS HU FS ER CP BO NA FS HU FS ER PC BO NA FS HU FS ER CP OB NA FS HU FS ER PC OB NA FS HU FS ER CP BO AN FS HU FS ER PC BO AN FS HU FS ER CP OB AN FS HU FS ER PC OB AN FS HU FS ER
Ruby
This one uses a case insensitive regular expression. The 'sub!' method substitutes the first substring it finds and returns nil if nothing is found. <lang ruby>words = %w(A BaRK BOoK tREaT COmMOn SqUAD CoNfuSE) << ""
words.each do |word|
blocks = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM" res = word.each_char.all?{|c| blocks.sub!(/\w?#{c}\w?/i, "")} #regexps can be interpolated like strings puts "#{word.inspect}: #{res}"
end </lang>
- Output:
"A": true "BaRK": true "BOoK": false "tREaT": true "COmMOn": false "SqUAD": true "CoNfuSE": true "": true
Scala
<lang Scala>object AbcBlocks extends App {
protected class Block(face1: Char, face2: Char) {
def isFacedWith(that: Char) = { that == face1 || that == face2 } override def toString() = face1.toString + face2 } protected object Block { def apply(faces: String) = new Block(faces.head, faces.last) }
type word = Seq[Block]
private val blocks = List(Block("BO"), Block("XK"), Block("DQ"), Block("CP"), Block("NA"), Block("GT"), Block("RE"), Block("TG"), Block("QD"), Block("FS"), Block("JW"), Block("HU"), Block("VI"), Block("AN"), Block("OB"), Block("ER"), Block("FS"), Block("LY"), Block("PC"), Block("ZM"))
private def isMakeable(word: String, blocks: word) = {
def getTheBlocks(word: String, blocks: word) = {
def inner(word: String, toCompare: word, rest: word, accu: word): word = { if (word.isEmpty || rest.isEmpty || toCompare.isEmpty) accu else if (toCompare.head.isFacedWith(word.head)) { val restant = rest diff List(toCompare.head) inner(word.tail, restant, restant, accu :+ toCompare.head) } else inner(word, toCompare.tail, rest, accu) } inner(word, blocks, blocks, Nil) }
word.lengthCompare(getTheBlocks(word, blocks).size) == 0 }
val words = List("A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSED", "ANBOCPDQERSFTGUVWXLZ") // Automatic tests assert(isMakeable(words(0), blocks)) assert(isMakeable(words(1), blocks)) assert(!isMakeable(words(2), blocks)) // BOOK not assert(isMakeable(words(3), blocks)) assert(!isMakeable(words(4), blocks)) // COMMON not assert(isMakeable(words(5), blocks)) assert(isMakeable(words(6), blocks)) assert(isMakeable(words(7), blocks))
//words(7).mkString.permutations.foreach(s => assert(isMakeable(s, blocks)))
words.foreach(w => println(s"$w can${if (isMakeable(w, blocks)) " " else "not "}be made."))
}</lang>
Seed7
<lang seed7>$ include "seed7_05.s7i";
const func boolean: canMakeWords (in array string: blocks, in string: word) is func
result var boolean: okay is FALSE; local var integer: index is 1; begin if word = "" then okay := TRUE; elsif length(blocks) <> 0 then while index <= length(blocks) and not okay do if blocks[index][1] = word[1] or blocks[index][2] = word[1] then okay := canMakeWords(blocks[.. pred(index)] & blocks[succ(index) ..], word[2 ..]); end if; incr(index); end while; end if; end func;
const array string: blocks is [] ("BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM");
const func boolean: canMakeWords (in string: word) is
return canMakeWords(blocks, upper(word));
const proc: main is func
local var string: word is ""; begin for word range [] ("", "A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "Confuse") do writeln(word rpad 10 <& canMakeWords(word)); end for; end func;</lang>
- Output:
TRUE A TRUE BARK TRUE BOOK FALSE TREAT TRUE COMMON FALSE SQUAD TRUE Confuse TRUE
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._n;
if(not b.holds(word[0])) continue; // letter not on this block blks.del(n); // remove this block from pile if (self.fcn(blks,word[1,*])) return(True); // try remaining blocks blks.insert(n,b); // put block back in pile: backtracking
} False; // out of blocks but not out of word }(blocks.copy(),word.toUpper())
}
foreach word in (T("","A","BarK","BOOK","TREAT","COMMON","SQUAD","Confuse","abba")){
can_make_word(word).println(": ",word);
}</lang>
- Output:
True: True: A True: BarK False: BOOK True: TREAT False: COMMON True: SQUAD True: Confuse True: abba
- Programming Tasks
- Solutions by Programming Task
- Ada
- AutoHotkey
- Batch File
- BBC BASIC
- Bracmat
- C
- C++
- C sharp
- Clojure
- Common Lisp
- D
- Euphoria
- FBSL
- Fortran
- Go
- Harbour
- Haskell
- Icon
- Unicon
- J
- Java
- JavaScript
- Jq
- Julia
- Mathematica
- MATLAB
- Nimrod
- OCaml
- Perl
- Perl 6
- PHP
- PicoLisp
- PL/I
- PowerBASIC
- Prolog
- Python
- R
- Racket
- REXX
- Ruby
- Scala
- Seed7
- Smalltalk
- Swift
- Tcl
- TUSCRIPT
- TXR
- UNIX Shell
- Zkl