ABC problem
![Task](http://static.miraheze.org/rosettacodewiki/thumb/b/ba/Rcode-button-task-crushed.png/64px-Rcode-button-task-crushed.png)
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 (maybe like the ones you had when you were a kid).
There are twenty blocks with two letters on each block.
A complete alphabet is guaranteed amongst all sides of the blocks.
The sample collection of 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)
- Task
Write a function that takes a string (word) and determines whether the word can be spelled 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 the output on this page for the following 7 words in the following example
- 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>
- Metrics
- Counting
- Word frequency
- Letter frequency
- Jewels and stones
- I before E except after C
- Bioinformatics/base count
- Count occurrences of a substring
- Count how many vowels and consonants occur in a string
- Remove/replace
- XXXX redacted
- Conjugate a Latin verb
- Remove vowels from a string
- String interpolation (included)
- Strip block comments
- Strip comments from a string
- Strip a set of characters from a string
- Strip whitespace from a string -- top and tail
- Strip control codes and extended characters from a string
- Anagrams/Derangements/shuffling
- Word wheel
- ABC problem
- Sattolo cycle
- Knuth shuffle
- Ordered words
- Superpermutation minimisation
- Textonyms (using a phone text pad)
- Anagrams
- Anagrams/Deranged anagrams
- Permutations/Derangements
- Find/Search/Determine
- ABC words
- Odd words
- Word ladder
- Semordnilap
- Word search
- Wordiff (game)
- String matching
- Tea cup rim text
- Alternade words
- Changeable words
- State name puzzle
- String comparison
- Unique characters
- Unique characters in each string
- Extract file extension
- Levenshtein distance
- Palindrome detection
- Common list elements
- Longest common suffix
- Longest common prefix
- Compare a list of strings
- Longest common substring
- Find common directory path
- Words from neighbour ones
- Change e letters to i in words
- Non-continuous subsequences
- Longest common subsequence
- Longest palindromic substrings
- Longest increasing subsequence
- Words containing "the" substring
- Sum of the digits of n is substring of n
- Determine if a string is numeric
- Determine if a string is collapsible
- Determine if a string is squeezable
- Determine if a string has all unique characters
- Determine if a string has all the same characters
- Longest substrings without repeating characters
- Find words which contains all the vowels
- Find words which contains most consonants
- Find words which contains more than 3 vowels
- Find words which first and last three letters are equals
- Find words which odd letters are consonants and even letters are vowels or vice_versa
- Formatting
- Substring
- Rep-string
- Word wrap
- String case
- Align columns
- Literals/String
- Repeat a string
- Brace expansion
- Brace expansion using ranges
- Reverse a string
- Phrase reversals
- Comma quibbling
- Special characters
- String concatenation
- Substring/Top and tail
- Commatizing numbers
- Reverse words in a string
- Suffixation of decimal numbers
- Long literals, with continuations
- Numerical and alphabetical suffixes
- Abbreviations, easy
- Abbreviations, simple
- Abbreviations, automatic
- Song lyrics/poems/Mad Libs/phrases
- Mad Libs
- Magic 8-ball
- 99 Bottles of Beer
- The Name Game (a song)
- The Old lady swallowed a fly
- The Twelve Days of Christmas
- Tokenize
- Text between
- Tokenize a string
- Word break problem
- Tokenize a string with escaping
- Split a character string based on change of character
- Sequences
11l
<lang 11l>F can_make_word(word)
I word == ‘’ R 0B
V blocks_remaining = ‘BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM’.split(‘ ’)
L(ch) word.uppercase() L(block) blocks_remaining I ch C block blocks_remaining.remove(block) L.break L.was_no_break R 0B R 1B
print([‘’, ‘a’, ‘baRk’, ‘booK’, ‘treat’, ‘COMMON’, ‘squad’, ‘Confused’].map(w -> ‘'’w‘': ’can_make_word(w)).join(‘, ’))</lang>
360 Assembly
The program uses one ASSIST macro (XPRNT) to keep the code as short as possible. <lang 360asm>* ABC Problem 21/07/2016 ABC CSECT
USING ABC,R13 base register B 72(R15) skip savearea DC 17F'0' savearea STM R14,R12,12(R13) prolog ST R13,4(R15) " <- ST R15,8(R13) " -> LR R13,R15 " addressability LA R8,1 l=1
LOOPL C R8,=A(NN) do l=1 to hbound(words)
BH ELOOPL LR R1,R8 l MH R1,=H'20' *20 LA R10,WORDS-20(R1) @words(l) MVC STATUS,=CL5'true' cflag='true' MVC TBLOCKS,BLOCKS tblocks=blocks MVC CC(1),0(R10) cc=substr(words(l),1,1) LA R6,1 i=1
LOOPI CLI CC,C' ' do while cc<>' '
BE ELOOPI SR R7,R7 k=0 LH R0,=H'1' m=1
LOOPM CH R0,=AL2(L'TBLOCKS) do m=1 to length(tblocks)
BH ELOOPM LA R5,TBLOCKS-1 @tblocks[0] AR R5,R0 @tblocks[m] CLC 0(1,R5),CC if substr(tblocks,m,1)=cc BNE INDEXM LR R7,R0 k=m=index(tblocks,cc) B ELOOPM
INDEXM AH R0,=H'1' m=m+1
B LOOPM
ELOOPM LTR R7,R7 if k=0
BNZ OKK MVC STATUS,=CL5'false' cflag='false' B EIFK0
OKK LA R4,TBLOCKS-2 @tblocks[-1]
AR R4,R7 +k CLI 0(R4),C'(' if substr(tblocks,k-1,1)='(' BNE SECOND LA R0,1 j=1 B EIFBLOCK
SECOND LA R0,3 j=3 EIFBLOCK LR R2,R7 k
SR R2,R0 k-j LA R4,TBLOCKS-1 @tblocks[0] AR R4,R2 @tblocks[k-j] MVC 0(5,R4),=CL5' ' substr(tblocks,k-j,5)=' '
EIFK0 LA R6,1(R6) i=i+1
LR R4,R10 @words AR R4,R6 +i BCTR R4,0 -1 MVC CC,0(R4) cc=substr(words,i,1) B LOOPI
ELOOPI MVC PG(20),0(R10) tabword(l)
MVC PG+20(5),STATUS status XPRNT PG,80 print buffer LA R8,1(R8) l=l+1 B LOOPL
ELOOPL L R13,4(0,R13) epilog
LM R14,R12,12(R13) " restore XR R15,R15 " rc=0 BR R14 exit
WORDS DC CL20'A',CL20'BARK',CL20'BOOK',CL20'TREAT',CL20'COMMON'
DC CL20'SQUAD',CL20'CONFUSE'
BLOCKS DS 0CL122
DC CL61'((B O) (X K) (D Q) (C P) (N A) (G T) (R E) (T G) (Q D) (F S) ' DC CL61'(J W) (H U) (V I) (A N) (O B) (E R) (F S) (L Y) (P C) (Z M)) '
TBLOCKS DS CL(L'BLOCKS) work blocks CC DS CL1 letter to find STATUS DS CL5 true/false PG DC CL80' ' buffer
YREGS
NN EQU (BLOCKS-WORDS)/L'WORDS number of words
END ABC</lang>
- Output:
A true BARK true BOOK false TREAT true COMMON false SQUAD true CONFUSE true
8080 Assembly
<lang 8080asm> org 100h jmp test ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Subroutine 'blocks': takes a $-terminated string in ;;; DE containing a word, and checks whether it can be ;;; written with the blocks. ;;; Returns: carry flag set if word is accepted. ;;; Uses registers: A, B, D, E, H, L blocks: push d ; Store string pointer lxi h,blockslist ; At the start, all blocks are lxi d,blocksavail ; available mvi b,40 blocksinit: mov a,m stax d inx h inx d dcr b jnz blocksinit pop d ; Restore string pointer blockschar: ldax d ; Get current character cpi '$' ; End of string? stc ; Set carry flag (accept string) rz ; And then we're done ani 0DFh ; Make uppercase lxi h,blocksavail ; Is it available? mvi b,40 blockscheck: cmp m jz blocksaccept ; Yes, we found it inx h ; Try next available char dcr b jnz blockscheck ana a ; Char unavailable, clear ret ; carry and stop. blocksaccept: mvi m,0 ; We've now used this char mov a,l ; And its blockmate xri 1 mov l,a mvi m,0 inx d ; Try next char in string jmp blockschar ;; Note: 'blocksavail' must not cross page boundary blockslist: db 'BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM' blocksavail: ds 40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Test code: run the subroutine on the given words. test: lxi h,words doword: mov e,m ; Get pointer to next word inx h mov d,m inx h mov a,e ; If zero, end of word list ora d rz push h ; Save pointer to list push d ; Save pointer to word mvi c,9 ; Write word to console call 5 pop d ; Retrieve word ponter call blocks ; Run the 'blocks' routine lxi d,yes ; Say 'yes', jc yesno ; if the carry is set. lxi d,no ; Otherwise, say 'no'. yesno: mvi c,9 call 5 pop h ; Restore list pointer jmp doword ; Do next word yes: db ': Yes',13,10,'$' no: db ': No',13,10,'$' words: dw wrda,wrdbark,wrdbook,wrdtreat,wrdcommon dw wrdsquad,wrdconfuse,0 wrda: db 'A$' wrdbark: db 'BARK$' wrdbook: db 'BOOK$' wrdtreat: db 'TREAT$' wrdcommon: db 'COMMON$' wrdsquad: db 'SQUAD$' wrdconfuse: db 'CONFUSE$'</lang>
- Output:
A>blocks A: Yes BARK: Yes BOOK: No TREAT: Yes COMMON: No SQUAD: Yes CONFUSE: Yes
8086 Assembly
<lang asm> cpu 8086 bits 16 org 100h section .text jmp demo ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Subroutine "blocks": see if the $-terminated string in DS:BX ;;; can be written with the blocks. ;;; Returns: carry flag set if word is accepted. ;;; Uses registers: AL, BX, CX, SI, DI ;;; Assumes CS=DS=ES blocks: mov si,.list ; Set all blocks available mov di,.avail mov cx,20 rep movsw .char: mov al,[bx] ; Get current character inc bx cmp al,'$' ; Are we at the end? je .ok ; Then the string is accepted mov cx,40 ; If not, check if block is available mov di,.avail repne scasb test cx,cx ; This clears the carry flag jz .out ; If zero, block is not available dec di ; Zero out the block we found mov [di],ch ; CH is guaranteed 0 here xor di,1 ; Point at other character on block mov [di],ch ; Zero out that one too. jmp .char .ok: stc .out: ret .list: db 'BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM' .avail: db ' ' ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Test code: run the subroutine on the given words demo: mov bp,words wrd: mov dx,[bp] ; Get word test dx,dx ; End of words? jz stop mov ah,9 ; Print word int 21h mov bx,dx ; Run subroutine call blocks mov dx,yes ; Print yes or no depending on carry jc print mov dx,no print: mov ah,9 int 21h inc bp inc bp jmp wrd stop: ret section .data yes: db ': Yes',13,10,'$' no: db ': No',13,10,'$' words: dw .a,.bark,.book,.treat,.cmn,.squad,.confs,0 .a: db 'A$' .bark: db 'BARK$' .book: db 'BOOK$' .treat: db 'TREAT$' .cmn: db 'COMMON$' .squad: db 'SQUAD$' .confs: db 'CONFUSE$'</lang>
- Output:
A: Yes BARK: Yes BOOK: No TREAT: Yes COMMON: No SQUAD: Yes CONFUSE: Yes
8th
<lang 360asm> \ ======================================================================================== \ You are given a collection of ABC blocks \ There are twenty blocks with two letters on each block. \ A complete alphabet is guaranteed amongst all sides of the blocks. \ \ Write a function that takes a string (word) and determines whether \ the word can be spelled with the given collection of blocks. \ \ Rules: \ 1. Once a letter on a block is used that block cannot be used again \ 2. The function should be case-insensitive \ 3. Show the output on this page for the following 7 words in the following example \ can_make_word(???) where ??? is resp.: \ "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE" \ \ NOTE: \ to make the program readable for even n00bs, I have a comment at the end of each line. \ The comments take the form of: \ \ <stack> | <rstack> \ in order to be able to follow exactly what the program does. \ ========================================================================================
["BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS","JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"] var, blks ["a", "AbBa", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"] var, chkwrds
needs stack/rstack
a:new var, paths \ Keeps the combinatory explosion of letter paths var wrd var success var ix
- uni2char "" swap s:+ ;
- char2uni 0 s:@ nip ;
- rreset rstack st:clear drop ;
- addoneletter \ ix path -- \ ix path | letter
r@ \ ix path letter | letter s:+ \ ix newpath | letter paths @ \ ix newpath paths | letter -rot \ paths ix newval | letter a:! \ paths | letter drop \ | letter ;
- oneletter \ letter -- \ letter
>r \ | letter paths @ ' addoneletter a:each drop \ | letter ;
- addtwoletters \ ix path -- \ ix path | letter1 letter2 halflen
swap \ path ix | letter1 letter2 halflen dup \ path ix ix | letter1 letter2 halflen r@ \ path ix ix halflen | letter1 letter2 halflen n:< \ path ix bool | letter1 letter2 halflen if \ path ix | letter1 letter2 halflen swap \ ix path | letter1 letter2 halflen 1 rpick \ ix path letter | letter1 letter2 halflen else swap \ ix path | letter1 letter2 halflen 2 rpick \ ix path letter | letter1 letter2 halflen then s:+ \ ix newpath | letter1 letter2 halflen paths @ \ ix newpath paths | letter1 letter2 halflen -rot \ paths ix newpath | letter1 letter2 halflen a:! \ paths | letter1 letter2 halflen drop \ | letter1 letter2 halflen ;
- twoletters \ letters -- \ letters
\ fetch the 2 letters dup \ letters letters 1 s:lsub \ letters letter1 >r \ letters | letter1 1 s:rsub \ letter2 | letter1 >r \ | letter1 letter2 \ duplicate paths in itself paths @ dup a:+ \ paths | letter1 letter2 \ halfway length of array a:len \ paths len | letter1 letter2 2 / \ paths halflen | letter1 letter2 >r \ paths | letter1 letter2 halflen \ add letters to paths ' addtwoletters a:each drop \ | letter1 letter2 halflen rreset \ ;
- chkletter \ letter -- letter \ letter
dup \ letter letter wrd @ \ letter letter word swap uni2char \ letter word letter s:search \ letter word index null? \ letter word index bool nip \ letter word bool if \ letter word 2drop \ "" \ letter else \ letter word drop \ letter then \ ;
- buildpaths \ ix blk -- \ ix blk
nip \ blk ' chkletter s:map \ resultletters s:len \ resultletters len dup \ resultletters len len 0 \ resultletters len len 0 n:= \ resultletters len bool if \ resultletters len \ This block contains no letters of current word 2drop \ ;; \ exit word then \ resultletters len 1 \ resultletters len 1 n:= \ resultletters bool if \ resultletters oneletter \ else \ resultletters twoletters \ then ;
- chkokpath \ ix wrdch -- \ ix wrdch | path
swap \ wrdch ix | path ix ! \ wrdch | path r@ \ wrdch path | path dup \ wrdch path path | path "" \ wrdch path path "" | path s:= \ wrdch path bool | path if \ wrdch path | path \ Path is empty - no match 2drop \ | path break \ | path ;; \ | path then swap \ path wrdch | path uni2char \ path wrdch | path s:search \ path pos | path null? \ path pos bool | path if \ path pos | path \ Letter not found in path - no match 2drop \ | path break \ | path else \ path pos | path wrd @ \ path pos wrd | path s:len \ path pos wrd len | path nip \ path pos len | path n:1- \ path pos cix | path ix @ \ path pos cix ix | path n:= \ path pos bool | path if \ path pos | path \ We have a match! true success ! \ path pos | path 2drop \ | path break \ | path else \ path pos | path 1 \ path pos len | path s:- \ restpath | path rdrop >r \ | restpath then then ;
- chkpath \ ix path -- \ ix path
nip \ path >r \ | path wrd @ \ wrd | path ' chkokpath s:each \ | path rdrop \ success @ \ success
if \ break \
then ;
- chkwrd \ ix wrd -- \ ix wrd
nip \ wrd s:uc \ wrdupper "Word=" . dup . \ wrdupper wrd ! \ \ other word - clear paths paths @ a:clear "" a:push drop \ \ create path tree for this word blks @ ' buildpaths a:each drop \ \ check if word can be made from a path false success ! \ paths @ ' chkpath a:each drop \ success @ \ success "\t\t" . . cr \ ;
- app:main
chkwrds @ ' chkwrd a:each drop \ check if word can be made bye ;
</lang>
AArch64 Assembly
<lang AArch64 Assembly> /* ARM assembly AARCH64 Raspberry PI 3B */ /* program problemABC64.s */
/*******************************************/ /* Constantes file */ /*******************************************/ /* for this file see task include a file in language AArch64 assembly*/ .include "../includeConstantesARM64.inc" .equ TRUE, 1 .equ FALSE, 0
/*********************************/ /* Initialized data */ /*********************************/ .data szMessTitre1: .asciz "Can_make_word: @ \n" szMessTrue: .asciz "True.\n" szMessFalse: .asciz "False.\n" szCarriageReturn: .asciz "\n"
szTablBloc: .asciz "BO"
.asciz "XK" .asciz "DQ" .asciz "CP" .asciz "NA" .asciz "GT" .asciz "RE" .asciz "TG" .asciz "QD" .asciz "FS" .asciz "JW" .asciz "HU" .asciz "VI" .asciz "AN" .asciz "OB" .asciz "ER" .asciz "FS" .asciz "LY" .asciz "PC" .asciz "ZM" .equ NBBLOC, (. - szTablBloc) / 3
szWord1: .asciz "A" szWord2: .asciz "BARK" szWord3: .asciz "BOOK" szWord4: .asciz "TREAT" szWord5: .asciz "COMMON" szWord6: .asciz "SQUAD" szWord7: .asciz "CONFUSE" /*********************************/ /* UnInitialized data */ /*********************************/ .bss .align 4 qtabTopBloc: .skip 8 * NBBLOC /*********************************/ /* code section */ /*********************************/ .text .global main main: // entry of program
ldr x0,qAdrszWord1 bl traitBlock // control word
ldr x0,qAdrszWord2 bl traitBlock // control word ldr x0,qAdrszWord3 bl traitBlock // control word ldr x0,qAdrszWord4 bl traitBlock // control word ldr x0,qAdrszWord5 bl traitBlock // control word ldr x0,qAdrszWord6 bl traitBlock // control word ldr x0,qAdrszWord7 bl traitBlock // control word
100: // standard end of the program
mov x0, #0 // return code mov x8, #EXIT // request to exit program svc #0 // perform the system call
qAdrszCarriageReturn: .quad szCarriageReturn qAdrszWord1: .quad szWord1 qAdrszWord2: .quad szWord2 qAdrszWord3: .quad szWord3 qAdrszWord4: .quad szWord4 qAdrszWord5: .quad szWord5 qAdrszWord6: .quad szWord6 qAdrszWord7: .quad szWord7 /******************************************************************/ /* traitement */ /******************************************************************/ /* x0 contains word */ traitBlock:
stp x1,lr,[sp,-16]! // save registres mov x1,x0 ldr x0,qAdrszMessTitre1 // insertion word in message bl strInsertAtCharInc bl affichageMess // display title message mov x0,x1 bl controlBlock // control cmp x0,#TRUE // ok ? bne 1f ldr x0,qAdrszMessTrue // yes bl affichageMess b 100f
1: // no
ldr x0,qAdrszMessFalse bl affichageMess
100:
ldp x1,lr,[sp],16 // restaur des 2 registres ret
qAdrszMessTitre1: .quad szMessTitre1 qAdrszMessFalse: .quad szMessFalse qAdrszMessTrue: .quad szMessTrue /******************************************************************/ /* control if letters are in block */ /******************************************************************/ /* x0 contains word */ controlBlock:
stp x1,lr,[sp,-16]! // save registres stp x2,x3,[sp,-16]! // save registres stp x4,x5,[sp,-16]! // save registres stp x6,x7,[sp,-16]! // save registres stp x8,x9,[sp,-16]! // save registres mov x5,x0 // save word address ldr x4,qAdrqtabTopBloc ldr x6,qAdrszTablBloc mov x2,#0 mov x3,#0
1: // init table top block used
str x3,[x4,x2,lsl #3] add x2,x2,#1 cmp x2,#NBBLOC blt 1b mov x2,#0
2: // loop to load letters
ldrb w3,[x5,x2] cbz w3,10f // end mov x0,0xDF and x3,x3,x0 // transform in capital letter mov x8,#0
3: // begin loop control block
ldr x7,[x4,x8,lsl #3] // block already used ? cbnz x7,5f // yes add x9,x8,x8,lsl #1 // no -> index * 3 ldrb w7,[x6,x9] // first block letter cmp w3,w7 // equal ? beq 4f add x9,x9,#1 ldrb w7,[x6,x9] // second block letter cmp w3,w7 // equal ? beq 4f b 5f
4:
mov x7,#1 // top block str x7,[x4,x8,lsl #3] // block used add x2,x2,#1 b 2b // next letter
5:
add x8,x8,#1 cmp x8,#NBBLOC blt 3b mov x0,#FALSE // no letter find on block -> false b 100f
10: // all letters are ok
mov x0,#TRUE
100:
ldp x8,x9,[sp],16 // restaur des 2 registres ldp x6,x7,[sp],16 // restaur des 2 registres ldp x4,x5,[sp],16 // restaur des 2 registres ldp x2,x3,[sp],16 // restaur des 2 registres ldp x1,lr,[sp],16 // restaur des 2 registres ret
qAdrqtabTopBloc: .quad qtabTopBloc qAdrszTablBloc: .quad szTablBloc /********************************************************/ /* File Include fonctions */ /********************************************************/ /* for this file see task include a file in language AArch64 assembly */ .include "../includeARM64.inc" </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.
ABAP
<lang ABAP> REPORT z_rosetta_abc.
" Type declaration for blocks of letters TYPES: BEGIN OF block,
s1 TYPE char1, s2 TYPE char1, END OF block,
blocks_table TYPE STANDARD TABLE OF block.
DATA: blocks TYPE blocks_table.
CLASS word_maker DEFINITION.
PUBLIC SECTION. CLASS-METHODS: can_make_word IMPORTING word TYPE string letter_blocks TYPE blocks_table RETURNING VALUE(found) TYPE abap_bool.
ENDCLASS.
CLASS word_maker IMPLEMENTATION.
METHOD can_make_word.
" Create a reader stream that reads 1 character at a time DATA(reader) = NEW cl_abap_string_c_reader( word ).
DATA(blocks) = letter_blocks.
WHILE reader->data_available( ).
DATA(ch) = to_upper( reader->read( 1 ) ). found = abap_false.
LOOP AT blocks REFERENCE INTO DATA(b). IF ch = b->s1 OR ch = b->s2. found = abap_true. DELETE blocks INDEX sy-tabix. EXIT. " the inner loop once a character is found ENDIF. ENDLOOP.
" If a character could not be found, stop looking further IF found = abap_false. RETURN. ENDIF. ENDWHILE.
ENDMETHOD.
ENDCLASS.
START-OF-SELECTION.
blocks = VALUE #( ( s1 = 'B' s2 = 'O' ) ( s1 = 'X' s2 = 'K' ) ( s1 = 'D' s2 = 'Q' ) ( s1 = 'C' s2 = 'P' ) ( s1 = 'N' s2 = 'A' ) ( s1 = 'G' s2 = 'T' ) ( s1 = 'R' s2 = 'E' ) ( s1 = 'T' s2 = 'G' ) ( s1 = 'Q' s2 = 'D' ) ( s1 = 'F' s2 = 'S' ) ( s1 = 'J' s2 = 'W' ) ( s1 = 'H' s2 = 'U' ) ( s1 = 'V' s2 = 'I' ) ( s1 = 'A' s2 = 'N' ) ( s1 = 'O' s2 = 'B' ) ( s1 = 'E' s2 = 'R' ) ( s1 = 'F' s2 = 'S' ) ( s1 = 'L' s2 = 'Y' ) ( s1 = 'P' s2 = 'C' ) ( s1 = 'Z' s2 = 'M' ) ).
WRITE:/ COND string( WHEN word_maker=>can_make_word( word = 'A' letter_blocks = blocks ) = abap_true THEN 'True' ELSE 'False' ). WRITE:/ COND string( WHEN word_maker=>can_make_word( word = 'BARK' letter_blocks = blocks ) = abap_true THEN 'True' ELSE 'False' ). WRITE:/ COND string( WHEN word_maker=>can_make_word( word = 'BOOK' letter_blocks = blocks ) = abap_true THEN 'True' ELSE 'False' ). WRITE:/ COND string( WHEN word_maker=>can_make_word( word = 'TREAT' letter_blocks = blocks ) = abap_true THEN 'True' ELSE 'False' ). WRITE:/ COND string( WHEN word_maker=>can_make_word( word = 'COMMON' letter_blocks = blocks ) = abap_true THEN 'True' ELSE 'False' ). WRITE:/ COND string( WHEN word_maker=>can_make_word( word = 'SQUAD' letter_blocks = blocks ) = abap_true THEN 'True' ELSE 'False' ). WRITE:/ COND string( WHEN word_maker=>can_make_word( word = 'CONFUSE' letter_blocks = blocks ) = abap_true THEN 'True' ELSE 'False' ).
</lang>
- Output:
True True False True False True True
Action!
<lang Action!>DEFINE COUNT="20" CHAR ARRAY sideA="BXDCNGRTQFJHVAOEFLPZ" CHAR ARRAY sideB="OKQPATEGDSWUINBRSYCM" BYTE ARRAY used(COUNT)
BYTE FUNC ToUpper(BYTE c)
IF c>='a AND c<='z THEN RETURN (c-'a+'A) FI
RETURN (c)
BYTE FUNC CanBeUsed(CHAR c)
BYTE i
FOR i=0 TO COUNT-1 DO IF used(i)=0 AND (sideA(i+1)=c OR sideB(i+1)=c) THEN used(i)=1 RETURN (1) FI OD
RETURN (0)
BYTE FUNC Check(CHAR ARRAY s)
BYTE i CHAR c
FOR i=0 TO COUNT-1 DO used(i)=0 OD
FOR i=1 TO s(0) DO c=ToUpper(s(i)) IF CanBeUsed(c)=0 THEN RETURN (0) FI OD
RETURN (1)
PROC Test(CHAR ARRAY s)
Print(s) Print(": ") IF Check(s) THEN PrintE("can be made") ELSE PrintE("can not be made") FI
RETURN
PROC Main()
Test("a") Test("bARk") Test("book") Test("TReat") Test("coMMon") Test("SQuaD") Test("CoNfUsE")
RETURN</lang>
- Output:
Screenshot from Atari 8-bit computer
a: can be made bARk: can be made book: can not be made TReat: can be made coMMon: can not be made SQuaD: can be made CoNfUsE: can be made
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 "
Apex
<lang Java>static Boolean canMakeWord(List<String> src_blocks, String word) {
if (String.isEmpty(word)) { return true; }
List<String> blocks = new List<String>(); for (String block : src_blocks) { blocks.add(block.toUpperCase()); } for (Integer i = 0; i < word.length(); i++) { Integer blockIndex = -1; String c = word.mid(i, 1).toUpperCase(); for (Integer j = 0; j < blocks.size(); j++) { if (blocks.get(j).contains(c)) { blockIndex = j; break; } } if (blockIndex == -1) { return false; } else { blocks.remove(blockIndex); } } return true;
}
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'
}; System.debug('"": ' + canMakeWord(blocks, )); System.debug('"A": ' + canMakeWord(blocks, 'A')); System.debug('"BARK": ' + canMakeWord(blocks, 'BARK')); System.debug('"book": ' + canMakeWord(blocks, 'book')); System.debug('"treat": ' + canMakeWord(blocks, 'treat')); System.debug('"COMMON": ' + canMakeWord(blocks, 'COMMON')); System.debug('"SQuAd": ' + canMakeWord(blocks, 'SQuAd')); System.debug('"CONFUSE": ' + canMakeWord(blocks, 'CONFUSE'));</lang>
- Output:
"": true "A": true "BARK": true "book": false "treat": true "COMMON": false "SQuAd": true "CONFUSE": true
APL
<lang APL>abc←{{0=⍴⍵:1 ⋄ 0=⍴h←⊃⍵:0 ⋄ ∇(t←1↓⍵)~¨⊃h:1 ⋄ ∇(⊂1↓h),t}⍸¨↓⍵∘.∊⍺}</lang>
- Output:
)COPY dfns ucase b W←(≠∘' '⊆⊢)∘ucase¨'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' b∘abc¨W 1 1 0 1 0 1 1
AppleScript
Imperative
<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>
Functional
<lang AppleScript>use AppleScript version "2.4" use framework "Foundation"
ABC Problem -----------------------
-- spellWith :: [String] -> [Char] -> String on spellWith(blocks, cs)
if 0 < length of cs then set x to item 1 of cs script go on |λ|(b) if b contains x then map(my cons(b), ¬ spellWith(|delete|(b, blocks), rest of cs)) else {} end if end |λ| end script concatMap(go, blocks) else {{}} end if
end spellWith
TEST ---------------------------
on run
set blocks to ¬ words of "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM" script test on |λ|(w) justifyRight(9, space, quoted("'", w)) & " -> " & ¬ ({} ≠ spellWith(blocks, characters of toUpper(w))) end |λ| end script unlines(map(test, ¬ ["", "A", "BARK", "BoOK", "TrEAT", "COmMoN", "SQUAD", "conFUsE"]))
end run
GENERIC FUNCTIONS --------------------
-- Just :: a -> Maybe a on Just(x)
-- Constructor for an inhabited Maybe (option type) value. -- Wrapper containing the result of a computation. {type:"Maybe", Nothing:false, Just:x}
end Just
-- Nothing :: Maybe a
on Nothing()
-- Constructor for an empty Maybe (option type) value. -- Empty wrapper returned where a computation is not possible. {type:"Maybe", Nothing:true}
end Nothing
-- elemIndex :: Eq a => a -> [a] -> Maybe Int
on elemIndex(x, xs)
set lng to length of xs repeat with i from 1 to lng if x = (item i of xs) then return Just(i) end repeat return Nothing()
end elemIndex
-- concatMap :: (a -> [b]) -> [a] -> [b]
on concatMap(f, xs)
set lng to length of xs set acc to {} tell mReturn(f) repeat with i from 1 to lng set acc to acc & (|λ|(item i of xs, i, xs)) end repeat end tell return acc
end concatMap
-- cons :: a -> [a] -> [a]
on cons(x)
script on |λ|(xs) {x} & xs end |λ| end script
end cons
-- delete :: Eq a => a -> [a] -> [a]
on |delete|(x, xs)
set mbIndex to elemIndex(x, xs) set lng to length of xs if Nothing of mbIndex then xs else if 1 < lng then set i to Just of mbIndex if 1 = i then items 2 thru -1 of xs else if lng = i then items 1 thru -2 of xs else tell xs to items 1 thru (i - 1) & items (i + 1) thru -1 end if else {} end if end if
end |delete|
-- justifyRight :: Int -> Char -> String -> String
on justifyRight(n, cFiller, strText)
if n > length of strText then text -n thru -1 of ((replicate(n, cFiller) as text) & strText) else strText end if
end justifyRight
-- mReturn :: First-class m => (a -> b) -> m (a -> b)
on mReturn(f)
-- 2nd class handler function lifted into 1st class script wrapper. if script is class of f then f else script property |λ| : f end script end if
end mReturn
-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
-- The list obtained by applying f -- to each element of xs. tell mReturn(f) set lng to length of xs set lst to {} repeat with i from 1 to lng set end of lst to |λ|(item i of xs, i, xs) end repeat return lst end tell
end map
-- quoted :: Char -> String -> String
on quoted(c, s)
-- string flanked on both sides -- by a specified quote character. c & s & c
end quoted
-- replicate :: Int -> String -> String
on replicate(n, s)
set out to "" if n < 1 then return out set dbl to s repeat while (n > 1) if (n mod 2) > 0 then set out to out & dbl set n to (n div 2) set dbl to (dbl & dbl) end repeat return out & dbl
end replicate
-- toUpper :: String -> String
on toUpper(str)
set ca to current application ((ca's NSString's stringWithString:(str))'s ¬ uppercaseStringWithLocale:(ca's NSLocale's currentLocale())) as text
end toUpper
-- unlines :: [String] -> String
on unlines(xs)
-- A single string formed by the intercalation -- of a list of strings with the newline character. set {dlm, my text item delimiters} to ¬ {my text item delimiters, linefeed} set s to xs as text set my text item delimiters to dlm s
end unlines</lang>
- Output:
'' -> true 'A' -> true 'BARK' -> true 'BoOK' -> false 'TrEAT' -> true 'COmMoN' -> false 'SQUAD' -> true 'conFUsE' -> true
ARM Assembly
<lang ARM Assembly> /* ARM assembly Raspberry PI */ /* program problemABC.s */
/* REMARK 1 : this program use routines in a include file
see task Include a file language arm assembly for the routine affichageMess conversion10 see at end of this program the instruction include */
/* for constantes see task include a file in arm assembly */ /************************************/ /* Constantes */ /************************************/ .include "../constantes.inc" .equ TRUE, 1 .equ FALSE, 0
/*********************************/ /* Initialized data */ /*********************************/ .data szMessTitre1: .asciz "Can_make_word: @ \n" szMessTrue: .asciz "True.\n" szMessFalse: .asciz "False.\n" szCarriageReturn: .asciz "\n"
szTablBloc: .asciz "BO"
.asciz "XK" .asciz "DQ" .asciz "CP" .asciz "NA" .asciz "GT" .asciz "RE" .asciz "TG" .asciz "QD" .asciz "FS" .asciz "JW" .asciz "HU" .asciz "VI" .asciz "AN" .asciz "OB" .asciz "ER" .asciz "FS" .asciz "LY" .asciz "PC" .asciz "ZM" .equ NBBLOC, (. - szTablBloc) / 3
szWord1: .asciz "A" szWord2: .asciz "BARK" szWord3: .asciz "BOOK" szWord4: .asciz "TREAT" szWord5: .asciz "COMMON" szWord6: .asciz "SQUAD" szWord7: .asciz "CONFUSE" /*********************************/ /* UnInitialized data */ /*********************************/ .bss .align 4 itabTopBloc: .skip 4 * NBBLOC /*********************************/ /* code section */ /*********************************/ .text .global main main: @ entry of program
ldr r0,iAdrszWord1 bl traitBlock @ control word
ldr r0,iAdrszWord2 bl traitBlock @ control word ldr r0,iAdrszWord3 bl traitBlock @ control word ldr r0,iAdrszWord4 bl traitBlock @ control word ldr r0,iAdrszWord5 bl traitBlock @ control word ldr r0,iAdrszWord6 bl traitBlock @ control word ldr r0,iAdrszWord7 bl traitBlock @ control word
100: @ standard end of the program
mov r0, #0 @ return code mov r7, #EXIT @ request to exit program svc #0 @ perform the system call
iAdrszCarriageReturn: .int szCarriageReturn iAdrszWord1: .int szWord1 iAdrszWord2: .int szWord2 iAdrszWord3: .int szWord3 iAdrszWord4: .int szWord4 iAdrszWord5: .int szWord5 iAdrszWord6: .int szWord6 iAdrszWord7: .int szWord7 /******************************************************************/ /* traitement */ /******************************************************************/ /* r0 contains word */ traitBlock:
push {r1,lr} @ save registers mov r1,r0 ldr r0,iAdrszMessTitre1 @ insertion word in message bl strInsertAtCharInc bl affichageMess @ display title message mov r0,r1 bl controlBlock @ control cmp r0,#TRUE @ ok ? bne 1f ldr r0,iAdrszMessTrue @ yes bl affichageMess b 100f
1: @ no
ldr r0,iAdrszMessFalse bl affichageMess
100:
pop {r1,lr} bx lr @ return
iAdrszMessTitre1: .int szMessTitre1 iAdrszMessFalse: .int szMessFalse iAdrszMessTrue: .int szMessTrue /******************************************************************/ /* control if letters are in block */ /******************************************************************/ /* r0 contains word */ controlBlock:
push {r1-r9,lr} @ save registers mov r5,r0 @ save word address ldr r4,iAdritabTopBloc ldr r6,iAdrszTablBloc mov r2,#0 mov r3,#0
1: @ init table top block used
str r3,[r4,r2,lsl #2] add r2,r2,#1 cmp r2,#NBBLOC blt 1b mov r2,#0
2: @ loop to load letters
ldrb r3,[r5,r2] cmp r3,#0 beq 10f @ end and r3,r3,#0xDF @ transform in capital letter mov r8,#0
3: @ begin loop control block
ldr r7,[r4,r8,lsl #2] @ block already used ? cmp r7,#0 bne 5f @ yes add r9,r8,r8,lsl #1 @ no -> index * 3 ldrb r7,[r6,r9] @ first block letter cmp r3,r7 @ equal ? beq 4f add r9,r9,#1 ldrb r7,[r6,r9] @ second block letter cmp r3,r7 @ equal ? beq 4f b 5f
4:
mov r7,#1 @ top block str r7,[r4,r8,lsl #2] @ block used add r2,r2,#1 b 2b @ next letter
5:
add r8,r8,#1 cmp r8,#NBBLOC blt 3b mov r0,#FALSE @ no letter find on block -> false b 100f
10: @ all letters are ok
mov r0,#TRUE
100:
pop {r1-r9,lr} bx lr @ return
iAdritabTopBloc: .int itabTopBloc iAdrszTablBloc: .int szTablBloc /***************************************************/ /* ROUTINES INCLUDE */ /***************************************************/ .include "../affichage.inc" </lang>
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.
Arturo
<lang rebol>blocks: map [
[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]
] => [ join map & => [to :string]]
charInBlock: function [ch,bl][
loop.with:'i bl 'b -> if contains? b upper ch [ return i ] return ø
]
canMakeWord?: function [wrd][
ref: new blocks loop split wrd 'chr [ cib: charInBlock chr ref if? cib = ø [ return false ] else [ ref: remove ref .index cib ] ] return true
]
loop ["A" "BaRk" "bOoK" "tReAt" "CoMmOn" "SqUaD" "cONfUsE"] 'wrd
-> print [wrd "=>" canMakeWord? wrd]</lang>
- Output:
A => true BaRk => true bOoK => false tReAt => true CoMmOn => false SqUaD => true cONfUsE => true
Astro
<lang python>fun abc(s, ls):
if ls.isempty: return true for i in indices(list) where s[end] in list[i]: return abc(s[:end-1], remove!(copy(list), at: i)) false
let test = ["A", "BARK","BOOK","TREAT","COMMON","SQUAD","CONFUSE"] let ls = ["BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS", "JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"]
for s in test:
print "($|>8|{s} ${abc(s, list)})"</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
AWK
Here are 2 slightly different versions:
#!/usr/bin/awk -f # tested with mawk 1.3.3 on Raspberry Pi 3 # also GNU awk 3.1.5, busybox 1.21.1 and 1.27.1 on AMD Sempron 2800+ # function setblocks() { # key to the algorithm is the representation of a block # each block is represented by 4 characters in the string "blocks" # for example, the "BO" block becomes "-BO-" # blocks="-BO--XK--DQ--CP--NA--GT--RE--TG--QD--FS--JW--HU--VI--AN--OB--ER--FS--LY--PC--ZM-" true=1 false=0 } function found(letter){ # # the function "found" scans for the letter on the top of a block # using the pattern "-B", for example, to find a "B", # returning "true" (or 1) if found # if not found on the top, look on the bottoms using the pattern "B-" # again returning "true" if found # if the letter is found on either top or bottom, the 4 character block is set to "----" # so that block is unavailable # finally, if no available copy of letter is found, # the function returns "false" (0) position= index(blocks,"-" letter) if (position > 0) { blocks = substr(blocks,1,position-1) "----" substr(blocks,position+4) return true } position = index(blocks,letter "-") if (position > 0) {blocks = substr(blocks,1,position-3) "----" substr(blocks,position+2) return true } return false } # awk's BEGIN statement allows for initialization before processing input; # in this case, initializing the string "blocks" # BEGIN{ setblocks() } # in awk, the input record is contained in the string variable "$0" # the main process checks each letter in turn to see if it is on a usable block, # summing the values returned by "found" # if the sum equals the number of input characters the word can be spelled with the blocks # otherwise it is not possible # { nchars=length($0) possible=false for (i=1;i<=nchars;i++){ possible=possible + found(substr($0,i,1)) } if (possible==nchars) print $0 " is possible" else print $0 " is not possible" setblocks() }
and -----------------
#!/usr/bin/awk -f # tested with mawk 1.3.3 on Raspberry Pi 3 # also GNU awk 3.1.5, busybox 1.21.1 and 1.27.1 on AMD Sempron 2800+ # function setblocks() { # # key to the algorithm is the representation of the blocks # each block is represented by 1 character in the string "tops" # and by 1 character in the string "bottoms" # tops="BXDCNGRTQFJHVAOEFLPZ" bottoms="OKQPATEGDSWUINBRSYCM" true=1 false=0 } function found(letter){ # # the function "found" scans first the string "tops" for a letter and # then the string "bottoms" if the letter is not in "tops" # if the letter is found, it marks "tops" and "bottoms" to show # the block is unavailable by changing the letters on the block to "-" # and returns "true" (1); if the letter is not found # the function returns "false" (0) # position= index(tops,letter) if (position > 0) { tops = substr(tops,1,position-1) "-" substr(tops,position+1) bottoms = substr(bottoms,1,position-1) "-" substr(bottoms,position+1) return true } position = index(bottoms,letter) if (position > 0) {bottoms = substr(bottoms,1,position-1) "-" substr(bottoms,position+1) tops = substr(tops,1,position-1) "-" substr(tops,position+1) return true } return false } # awk's BEGIN statement allows for initialization before processing input; # in this case, initializing the string "blocks" # BEGIN{ setblocks() } # in awk, the input record is contained in the string variable "$0" # the main process checks each letter in turn to see if it is on a usable block, # summing the values returned by "found" # if the sum equals the number of input characters the word can be spelled with the blocks # otherwise it is not possible # { nchars=length($0) possible=false for (i=1;i<=nchars;i++){ possible=possible + found(substr($0,i,1)) } if (possible==nchars) print $0 " is possible" else print $0 " is not possible" setblocks() }
- Output:
pi@raspberrypi:~/Documents/rosettacode $ ./abcProblem.awk A A is possible BARK BARK is possible BOOK BOOK is not possible TREAT TREAT is possible COMMON COMMON is not possible SQUAD SQUAD is possible CONFUSE CONFUSE is possible ^C pi@raspberrypi:~/Documents/rosettacode $
BaCon
<lang qbasic>CONST info$ = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM"
DATA "A", "BARK", "BOOK", "TREAT", "Common", "Squad", "Confuse"
WHILE TRUE
READ word$
IF NOT(LEN(word$)) THEN BREAK
block$ = info$
count = AMOUNT(block$)
FOR y = 1 TO LEN(word$) FOR x = 1 TO AMOUNT(block$) IF TALLY(TOKEN$(block$, x), MID$(UCASE$(word$), y, 1)) THEN block$ = DEL$(block$, x) BREAK END IF NEXT NEXT
PRINT word$, IIF$(LEN(word$) = count-AMOUNT(block$), "True", "False") FORMAT "%-10s: %s\n"
WEND</lang>
- Output:
A : True BARK : True BOOK : False TREAT : True Common : False Squad : True Confuse : True
BASIC
Works with:VB-DOS, QB64, QBasic, QuickBASIC <lang qbasic> ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ABC_Problem ' ' ' ' Developed by A. David Garza Marín in VB-DOS for ' ' RosettaCode. November 29, 2016. ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' Comment the following line to run it in QB or QBasic OPTION EXPLICIT ' Modify to OPTION _EXPLICIT for QB64
' SUBs and FUNCTIONs DECLARE SUB doCleanBlocks () DECLARE FUNCTION ICanMakeTheWord (WhichWord AS STRING) AS INTEGER DECLARE SUB doReadBlocks ()
' rBlock Data Type TYPE regBlock
Block AS STRING * 2 Used AS INTEGER
END TYPE
' Initialize CONST False = 0, True = NOT False, HMBlocks = 20 DATA "BO", "XK", "DQ", "CP", "NA", "GT","RE", "TG" DATA "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER" DATA "FS", "LY", "PC","ZM"
DIM rBlock(1 TO HMBlocks) AS regBlock DIM i AS INTEGER, aWord AS STRING, YorN AS STRING
doReadBlocks ' Read the data in the blocks
'-------------- Main program cycle ------------------ CLS PRINT "This program has the following blocks: "; FOR i = 1 TO HMBlocks
PRINT rBlock(i).Block; "|";
NEXT i PRINT : PRINT PRINT "Please, write a word or a short sentence to see if the available" PRINT "blocks can make it. If so, I will tell you." DO
doCleanBlocks ' Clean all blocks PRINT INPUT "Which is the word"; aWord aWord = LTRIM$(RTRIM$(aWord))
IF aWord <> "" THEN IF ICanMakeTheWord(aWord) THEN PRINT "Yes, i can make it." ELSE PRINT "No, I can't make it." END IF ELSE PRINT "At least, you need to type a letter." END IF
PRINT PRINT "Do you want to try again (Y/N) "; DO YorN = INPUT$(1) YorN = UCASE$(YorN) LOOP UNTIL YorN = "Y" OR YorN = "N" PRINT YorN
LOOP UNTIL YorN = "N" ' -------------- End of Main program ---------------- END
SUB doCleanBlocks ()
' Var SHARED rBlock() AS regBlock DIM i AS INTEGER
' Will clean the Used status of all blocks FOR i = 1 TO HMBlocks rBlock(i).Used = False NEXT i
END SUB
SUB doReadBlocks ()
' Var SHARED rBlock() AS regBlock DIM i AS INTEGER
' Will read the block values from DATA FOR i = 1 TO HMBlocks READ rBlock(i).Block NEXT i
END SUB
FUNCTION ICanMakeTheWord (WhichWord AS STRING) AS INTEGER ' Comment AS INTEGER to run in QBasic, QB64 and QuickBASIC
' Var SHARED rBlock() AS regBlock DIM i AS INTEGER, l AS INTEGER, j AS INTEGER, iYesICan AS INTEGER DIM c AS STRING, sUWord AS STRING
' Will evaluate if can make the word sUWord = UCASE$(WhichWord) l = LEN(sUWord) i = 0
DO i = i + 1 iYesICan = False c = MID$(sUWord, i, 1) j = 0 DO j = j + 1 IF NOT rBlock(j).Used THEN iYesICan = (INSTR(rBlock(j).Block, c) > 0) rBlock(j).Used = iYesICan END IF LOOP UNTIL j >= HMBlocks OR iYesICan
LOOP UNTIL i >= l OR NOT iYesICan
' The result will depend on the last value of ' iYesICan variable. If the last value is True ' is because the function found even the last ' letter analyzed. ICanMakeTheWord = iYesICan
END FUNCTION </lang>
Commodore BASIC
<lang basic>10 W$ = "A" : GOSUB 100 20 W$ = "BARK" : GOSUB 100 30 W$ = "BOOK" : GOSUB 100 40 W$ = "TREAT" : GOSUB 100 50 W$ = "COMMON" : GOSUB 100 60 W$ = "SQUAD" : GOSUB 100 70 W$ = "CONFUSE" : GOSUB 100 80 END 90 REM ******************************** 100 B$="BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM" 110 FOR I=1 TO LEN(W$) 120 : BL = LEN(B$) 130 : FOR J=1 TO BL STEP 2 140 : C$=MID$(B$,J,1): D$=MID$(B$,J+1,1) 150 : X$=MID$(W$,I,1) 160 : IF C$<>X$ AND D$<>X$ THEN GOTO 190 170 : B$ = LEFT$(B$,J-1)+RIGHT$(B$,BL-J-1) 180 : GOTO 210 190 : NEXT J 200 : IF J>BL-1 THEN GOTO 240 210 NEXT I 220 PRINT W$" -> YES" 230 RETURN 240 PRINT W$" -> NO" 250 RETURN</lang>
- Output:
A -> YES BARK -> YES BOOK -> NO TREAT -> YES COMMON -> NO SQUAD -> YES CONFUSE -> YES
Sinclair ZX81 BASIC
Works with 1k of RAM. A nice unstructured algorithm. Unfortunately the requirement that it be case-insensitive is moot, because the ZX81 does not support lower-case letters. <lang basic> 10 LET B$="BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"
20 INPUT W$ 30 FOR I=1 TO LEN W$ 40 FOR J=1 TO LEN B$ STEP 2 50 IF B$(J)<>W$(I) AND B$(J+1)<>W$(I) THEN GOTO 100 60 LET B$=B$( TO J-1)+B$(J+2 TO ) 70 NEXT I 80 PRINT "YES" 90 STOP
100 NEXT J 110 PRINT "NO"</lang>
- Input:
A
- Output:
YES
- Input:
BARK
- Output:
YES
- Input:
BOOK
- Output:
NO
- Input:
TREAT
- Output:
YES
- Input:
COMMON
- Output:
NO
- Input:
SQUAD
- Output:
YES
- Input:
CONFUSE
- Output:
YES
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
BCPL
<lang bcpl>get "libhdr"
let canMakeWord(word) = valof $( let blocks = "BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"
let avl = vec 40/BYTESPERWORD for i=0 to 39 do avl%i := blocks%(i+1) for i=1 to word%0 $( for j=0 to 39 $( let ch = word%i // make letter uppercase if 'a' <= ch <= 'z' then ch := ch - 32 if ch = avl%j then $( // this block is no longer available avl%j := 0 avl%(j neqv 1) := 0 // but we did find a block goto next $) $) resultis false // no block found next: loop $) resultis true
$)
let show(word) be
writef("%S: %S*N", word, canMakeWord(word) -> "yes", "no")
let start() be $( show("A")
show("BARK") show("book") show("Treat") show("CoMmOn") show("SQUAD") show("CONFUSE")
$)</lang>
- Output:
A: yes BARK: yes book: no Treat: yes CoMmOn: no SQUAD: yes CONFUSE: yes
BQN
<lang bqn>ABC ← {
Matches ← ⊑⊸(⊑∘∊¨)˜ /⊣ # blocks matching current letter Others ← <˘∘⍉∘(»⊸≥∨`)∘(≡⌜)/¨<∘⊣ # blocks without current matches 𝕨(×∘≠∘⊢ ◶ ⟨1˙, # if the word is empty, it can be made Matches(×∘≠∘⊣ ◶ ⟨0˙, # if no matching blocks, it cannot ∨´(𝕨 Others⊣) 𝕊¨ 1<∘↓⊢ # otherwise, remove block and try remaining letters ⟩)⊢ ⟩) (⊢-32×1="a{"⍋⊢)𝕩
}
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"⟩
> {(<𝕩) ∾ blocks ABC 𝕩}¨ words</lang>
- Output:
┌─ ╵ "A" 1 "bark" 1 "BOOK" 0 "TrEaT" 1 "Common" 0 "Squad" 1 "Confuse" 1 ┘
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#
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
C++
Build with: <lang sh>g++-4.7 -Wall -std=c++0x abc.cpp</lang> <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.
Ceylon
Functional programming/recursive solution. No variable values.
module.ceylon
<lang ceylon> module rosetta.abc "1.0.0" {} </lang>
run.ceylon
<lang ceylon> shared void run() {
printAndCanMakeWord("A", blocks); //True printAndCanMakeWord("BARK", blocks); //True printAndCanMakeWord("BOOK", blocks); //False printAndCanMakeWord("TREAT", blocks); //True printAndCanMakeWord("COMMON", blocks); //False printAndCanMakeWord("SQUAD", blocks); //True printAndCanMakeWord("CONFUSE", blocks); //True
}
Block[] blocks =
[ Block('B','O'), Block('X','K'), Block('D','Q'), Block('C','P'), Block('N','A'), Block('G','T'), Block('R','E'), Block('T','G'), Block('Q','D'), Block('F','S'), Block('J','W'), Block('H','U'), Block('V','I'), Block('A','N'), Block('O','B'), Block('E','R'), Block('F','S'), Block('L','Y'), Block('P','C'), Block('Z','M') ];
void printAndCanMakeWord(String word, Block[] blocks) {
print("``word``:``canMakeWord(word, blocks)``");
}
class Block(Character firstLetter, Character secondLetter) {
shared Character firstLetterUpper = firstLetter.uppercased; shared Character secondLetterUpper = secondLetter.uppercased;
shared Boolean containsLetter(Character letter) => let (letterUpper = letter.uppercased) firstLetterUpper == letterUpper || secondLetterUpper == letterUpper;
shared actual String string = "``firstLetterUpper``,``secondLetterUpper``";
}
Boolean canMakeWord(String word, Block[] blocks)
=> canMakeWordRecursive(word.uppercased.sequence(), 0, blocks, word.indexes());
Boolean canMakeWordRecursive(Character[] word,
Integer index, Block[] remainingBlocks, Integer[] remainingLetterIndexes) => if (exists wordFirst = word.first, // first is the Ceylon attribute for head exists remainingBlock = remainingBlocks.find((remainingBlock) => remainingBlock.containsLetter(wordFirst))) then let (myRemainingLetterIndexes = remainingLetterIndexes.filter((theIndex) => index != theIndex).sequence()) if (myRemainingLetterIndexes.empty) then true else canMakeWordRecursive(word.rest,// rest is the Ceylon attribute for tail index+1, // move through the letter indexes remainingBlocks.filter((block) => remainingBlock != block).sequence(), // one less block myRemainingLetterIndexes) else 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
CLU
<lang clu>ucase = proc (s: string) returns (string)
rslt: array[char] := array[char]$predict(1,string$size(s)) for c: char in string$chars(s) do if c>='a' & c<='z' then c := char$i2c(char$c2i(c) - 32) end array[char]$addh(rslt,c) end return(string$ac2s(rslt))
end ucase
abc = proc (s: string) returns (bool)
own collection: sequence[string] := sequence[string]$ ["BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS", "JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"] blocks: array[string] := sequence[string]$s2a(collection) for c: char in string$chars(ucase(s)) do begin for i: int in array[string]$indexes(blocks) do if string$indexc(c, blocks[i]) ~= 0 then blocks[i] := "" exit found end end return(false) end except when found: end end return(true)
end abc
start_up = proc ()
po: stream := stream$primary_output() words: sequence[string] := sequence[string]$ ["A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"] for word: string in sequence[string]$elements(words) do stream$puts(po, word || ": ") if abc(word) then stream$putl(po, "yes") else stream$putl(po, "no") end end
end start_up</lang>
- Output:
A: yes BARK: yes BOOK: no TREAT: yes COMMON: no SQUAD: yes CONFUSE: yes
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
Comal
<lang comal>0010 FUNC can'make'word#(word$) CLOSED 0020 blocks$:=" BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM" 0030 FOR i#:=1 TO LEN(word$) DO 0040 pos#:=UPPER$(word$(i#)) IN blocks$ 0050 IF NOT pos# THEN RETURN FALSE 0060 blocks$(pos#):="";blocks$(pos# BITXOR 1):="" 0070 ENDFOR i# 0080 RETURN TRUE 0090 ENDFUNC 0100 // 0110 DIM yesno$(0:1) OF 3 0120 yesno$(FALSE):="no";yesno$(TRUE):="yes" 0130 WHILE NOT EOD DO 0140 READ w$ 0150 PRINT w$,": ",yesno$(can'make'word#(w$)) 0160 ENDWHILE 0170 END 0180 // 0190 DATA "A","BARK","BOOK","treat","common","squad","CoNfUsE"</lang>
- Output:
A: yes BARK: yes BOOK: no treat: yes common: no squad: yes CoNfUsE: yes
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
Component Pascal
<lang oberon2> MODULE ABCProblem; IMPORT StdLog, DevCommanders, TextMappers; CONST notfound = -1; TYPE String = ARRAY 3 OF CHAR; VAR blocks : ARRAY 20 OF String;
PROCEDURE Check(s: ARRAY OF CHAR): BOOLEAN; VAR used: SET; i,blockIndex: INTEGER;
PROCEDURE GetBlockFor(c: CHAR): INTEGER; VAR i: INTEGER; BEGIN c := CAP(c); i := 0; WHILE (i < LEN(blocks)) DO IF (c = blocks[i][0]) OR (c = blocks[i][1]) THEN IF ~(i IN used) THEN RETURN i END END; INC(i) END; RETURN notfound END GetBlockFor;
BEGIN used := {}; FOR i := 0 TO LEN(s$) - 1 DO blockIndex := GetBlockFor(s[i]); IF blockIndex = notfound THEN RETURN FALSE ELSE INCL(used,blockIndex) END END; RETURN TRUE END Check;
PROCEDURE CanMakeWord*; VAR s: TextMappers.Scanner; BEGIN s.ConnectTo(DevCommanders.par.text); s.SetPos(DevCommanders.par.beg); s.Scan; WHILE (~s.rider.eot) DO IF (s.type = TextMappers.char) & (s.char = '~') THEN RETURN ELSIF (s.type = TextMappers.string) THEN StdLog.String(s.string);StdLog.String(":> "); StdLog.Bool(Check(s.string));StdLog.Ln END; s.Scan END 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";
END ABCProblem. </lang> Execute: ^Q ABCProblem.CanMakeWord A BARK BOOK TREAT COMMON SQUAD confuse~
- Output:
A:> $TRUE BARK:> $TRUE BOOK:> $FALSE TREAT:> $TRUE COMMON:> $FALSE SQUAD:> $TRUE confuse:> $TRUE
Cowgol
<lang cowgol>include "cowgol.coh"; include "strings.coh";
sub can_make_word(word: [uint8]): (r: uint8) is
var blocks: [uint8] := "BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"; # Initialize blocks array var avl: uint8[41]; CopyString(blocks, &avl[0]); r := 1; loop var letter := [word]; word := @next word; if letter == 0 then break; end if; # find current letter in blocks var i: @indexof avl := 0; loop var block := avl[i]; if block == 0 then # no block, this word cannot be formed r := 0; return; elseif block == letter then # we found it, blank it out avl[i] := ' '; avl[i^1] := ' '; # and the other letter on the block too break; end if; i := i + 1; end loop; end loop;
end sub;
- test a list of words
var words: [uint8][] := {"A","BARK","BOOK","TREAT","COMMON","SQUAD","CONFUSE"}; var resp: [uint8][] := {": No\n", ": Yes\n"}; var i: @indexof words := 0; while i < @sizeof words loop
print(words[i]); print(resp[can_make_word(words[i])]); i := i + 1;
end loop;</lang>
- Output:
A: Yes BARK: Yes BOOK: No TREAT: Yes COMMON: No SQUAD: Yes CONFUSE: Yes
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
Draco
<lang draco>\util.g
proc nonrec ucase(char c) char:
byte b; b := pretend(c, byte); b := b & ~32; pretend(b, char)
corp
proc nonrec can_make_word(*char w) bool:
[41] char blocks; word i; char ch; bool found, ok; CharsCopy(&blocks[0], "BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"); ok := true; while ch := ucase(w*); w := w + 1; ok and ch ~= '\e' do found := false; i := 0; while not found and i < 40 do if blocks[i] = ch then found := true fi; i := i + 1; od; if found then i := i - 1; blocks[i] := '\e'; blocks[i >< 1] := '\e' else ok := false fi od; ok
corp
proc nonrec test(*char w) void:
writeln(w, ": ", if can_make_word(w) then "yes" else "no" fi)
corp
proc nonrec main() void:
test("A"); test("BARK"); test("book"); test("treat"); test("CoMmOn"); test("sQuAd"); test("CONFUSE")
corp</lang>
- Output:
A: yes BARK: yes book: no treat: yes CoMmOn: no sQuAd: yes CONFUSE: yes
Dyalect
<lang dyalect>func blockable(str) {
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.Upper() var final = "" for c in strUp { for j in blocks.Indices() { if blocks[j].StartsWith(c) || blocks[j].EndsWith(c) { final += c blocks[j] = "" break } } } return final == strUp
}
func canOrNot(can) => can ? "can" : "cannot"
for str in [ "A", "BARK", "BooK", "TrEaT", "comMON", "sQuAd", "Confuse" ] {
print("\"\(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.
EchoLisp
<lang scheme> (lib 'list) ;; list-delete
(define BLOCKS '("BO" "XK" "DQ" "CP" "NA" "GT" "RE" "TG" "QD" "FS" "JW" "HU" "VI" "AN" "OB" "ER" "FS" "LY" "PC" "ZM" ))
(define WORDS '("A" "BARK" "BOOK" "TREAT" "COMMON" "SQUAD" "CONFUSE"))
(define (spell word blocks)
(cond
((string-empty? word) #t) ((empty? blocks) #f) (else (for/or [(block blocks)] #:continue (not (string-match block (string-first word))) (spell (string-rest word) (list-delete blocks block))))))
</lang>
- Output:
(for ((w WORDS)) (writeln (string-randcase w) (spell (string-upcase w) BLOCKS))) A #t bARK #t BooK #f TReAt #t ComMOn #f sqUAd #t COnfUSe #t
Ela
<lang ela>open list monad io char
- IO
null = foldr (\_ _ -> false) true
mapM_ f = foldr ((>>-) << f) (return ())
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"]
mapM_ (\w -> putLn (w, not << null $ abc blocks (map char.upper w)))
["", "A", "BARK", "BoOK", "TrEAT", "COmMoN", "SQUAD", "conFUsE"]</lang>
- Output:
("conFUsE",true) ("SQUAD",true) ("COmMoN",false) ("TrEAT",true) ("BoOK",false) ("BARK",true) ("A",true) ("",true)
Elena
ELENA 5.0 <lang elena>import system'routines; import system'collections; import extensions; import extensions'routines;
extension op {
canMakeWordFrom(blocks) { var list := ArrayList.load(blocks); ^ nil == (cast string(self)).upperCase().seekEach:(ch) { var index := list.indexOfElement ((word => word.indexOf(0, ch) != -1).asComparator()); if (index>=0) { list.removeAt(index); ^ false } else { ^ true } } }
}
public program() {
var blocks := new string[]{"BO", "XK", "DQ", "CP", "NA",
"GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"};
var words := new string[]{"", "A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "Confuse"}; Enumerator e := words.enumerator(); e.next(); words.forEach:(word) { console.printLine("can make '",word,"' : ",word.canMakeWordFrom(blocks)); }
}</lang>
- Output:
can make '' : true 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
Elixir
<lang elixir>defmodule ABC do
def can_make_word(word, avail) do can_make_word(String.upcase(word) |> to_charlist, avail, []) end defp can_make_word([], _, _), do: true defp can_make_word(_, [], _), do: false defp can_make_word([l|tail], [b|rest], tried) do (l in b 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..
F#
This solution does not depend on the order of the blocks, neither on the symmetry of blocks we see in the example block set. (Symmetry: if AB is a block, an A comes only with another AB|BA)
<lang fsharp>let rec spell_word_with blocks w =
let rec look_for_right_candidate candidates noCandidates c rest = match candidates with | [] -> false | c0::cc -> if spell_word_with (cc@noCandidates) rest then true else look_for_right_candidate cc (c0::noCandidates) c rest
match w with | "" -> true | w -> let c = w.[0] let rest = w.Substring(1) let (candidates, noCandidates) = List.partition(fun (c1,c2) -> c = c1 || c = c2) blocks look_for_right_candidate candidates noCandidates c rest
[<EntryPoint>] let main argv =
let default_blocks = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM" let blocks = (if argv.Length > 0 then argv.[0] else default_blocks).Split() |> List.ofArray |> List.map(fun s -> s.ToUpper()) |> List.map(fun s2 -> s2.[0], s2.[1]) let words = (if argv.Length > 0 then List.ofArray(argv).Tail else []) |> List.map(fun s -> s.ToUpper())
List.iter (fun w -> printfn "Using the blocks we can make the word '%s': %b" w (spell_word_with blocks w)) words 0</lang>
- Output:
h:\RosettaCode\ABC\Fsharp>RosettaCode "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM" a bark book threat common squad confuse Using the blocks we can make the word 'A': true Using the blocks we can make the word 'BARK': true Using the blocks we can make the word 'BOOK': false Using the blocks we can make the word 'THREAT': true Using the blocks we can make the word 'COMMON': false Using the blocks we can make the word 'SQUAD': true Using the blocks we can make the word 'CONFUSE': true h:\RosettaCode\ABC\Fsharp>RosettaCode "aB aB Ac Ac" abba Using the blocks we can make the word 'ABBA': true h:\RosettaCode\ABC\Fsharp>RosettaCode "US TZ AO QA" Auto Using the blocks we can make the word 'AUTO': true
Factor
<lang factor>USING: assocs combinators.short-circuit formatting grouping io kernel math math.statistics qw sequences sets unicode ; IN: rosetta-code.abc-problem
! === CONSTANTS ================================================
CONSTANT: blocks qw{
BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM
}
CONSTANT: input qw{ A BARK BOOK TREAT COMMON SQUAD CONFUSE }
! === PROGRAM LOGIC ============================================
- pare ( str -- seq )
[ blocks ] dip [ intersects? ] curry filter ;
- enough-blocks? ( str -- ? ) dup pare [ length ] bi@ <= ;
- enough-letters? ( str -- ? )
[ blocks concat ] dip dup [ within ] dip [ histogram values ] bi@ [ - ] 2map [ neg? ] any? not ;
- can-make-word? ( str -- ? )
>upper { [ enough-blocks? ] [ enough-letters? ] } 1&& ;
! === OUTPUT ===================================================
- show-blocks ( -- )
"Available blocks:" print blocks [ 1 cut "(%s %s)" sprintf ] map 5 group [ [ write bl ] each nl ] each nl ;
- header ( -- )
"Word" "Can make word from blocks?" "%-7s %s\n" printf "======= ==========================" print ;
- result ( str -- )
dup can-make-word? "Yes" "No" ? "%-7s %s\n" printf ;
! === MAIN =====================================================
- abc-problem ( -- )
show-blocks header input [ result ] each ;
MAIN: abc-problem</lang>
- Output:
Available 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) Word Can make word from blocks? ======= ========================== A Yes BARK Yes BOOK No TREAT Yes COMMON No SQUAD Yes CONFUSE Yes
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...
Forth
<lang forth>: blockslist s" BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM" ; variable blocks
- allotblocks ( -- ) here blockslist dup allot here over - swap move blocks ! ;
- freeblocks blockslist nip negate allot ;
- toupper 223 and ;
- clearblock ( addr-block -- )
dup '_' swap c! dup blocks @ - 1 and if 1- else 1+ then '_' swap c!
- pickblock ( addr-input -- addr-input+1 f )
dup 1+ swap c@ toupper ( -- addr-input+1 c ) blockslist nip 0 do
blocks @ i + dup c@ 2 pick ( -- addr-input+1 c addri ci c ) = if clearblock drop true unloop exit else drop then
loop drop false
- abc ( addr-input u -- f )
allotblocks 0 do
pickblock invert if drop false unloop exit cr then
loop drop true freeblocks
- .abc abc if ." True" else ." False" then ;</lang>
- Output:
s" A" .abc True ok s" BarK" .abc True ok s" BOOK" .abc False ok s" TrEaT" .abc True ok s" COMMON" .abc False ok s" SQUAD" .abc True ok s" CONFUSE" .abc True ok
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>
But if backtracking might be needed
The example set does not exercise the possible need for backtracking, as when an initial selection of blocks prevents completion because available letters have been used up. This can only arise when the same letter appears on more than one block and does so with different partners. The example set does contain duplicated letters, but they appear only via blocks with the same letters. Suppose instead that the block collection was AB, BC, CD, ... XY, YZ so that every letter appears twice except for A and Z. If the target word was STOPPED then both OP and PQ would be needed to supply P, but if the O had been supplied via OP then the second P would be unavailable. If instead the O were to be supplied by NO then all would be well.
The method involves the stack-style usage of array MOVE, but there is no explicit attempt at recursion. The array contains the possible moves at each level, and if necessary, a move made can later be retracted and an alternative sought. This is the standard style of playing board games such as chess via developing a "game tree", but in this case the tree traversal is not a large task.
The following source begins with some support routines. Subroutine PLAY inspects the collection of blocks to make various remarks, and function CANBLOCK reports on whether a word can be spelled out with the supplied blocks. The source requires only a few of the F90 features. The MODULE protocol eases communication, but the key feature is that subprograms can now declare arrays of a size determined on entry via parameters. Previously, a constant with the largest-possible size would be required. <lang Fortran>
MODULE PLAYPEN !Messes with a set of alphabet blocks. INTEGER MSG !Output unit number. PARAMETER (MSG = 6) !Standard output. INTEGER MS !I dislike unidentified constants... PARAMETER (MS = 2) !So this is the maximum number of lettered sides. INTEGER LETTER(26),SUPPLY(26) !For counting the alphabet. CONTAINS SUBROUTINE SWAP(I,J) !This really should be known to the compiler. INTEGER I,J,K !Which could generate in-place code, K = I !Using registers, maybe. I = J !Or maybe, there are special op-codes. J = K !Rather than this clunkiness. END SUBROUTINE SWAP !And it should be for any type of thingy.
INTEGER FUNCTION LSTNB(TEXT) !Sigh. Last Not Blank.
Concocted yet again by R.N.McLean (whom God preserve) December MM. Code checking reveals that the Compaq compiler generates a copy of the string and then finds the length of that when using the latter-day intrinsic LEN_TRIM. Madness! Can't DO WHILE (L.GT.0 .AND. TEXT(L:L).LE.' ') !Control chars. regarded as spaces. Curse the morons who think it good that the compiler MIGHT evaluate logical expressions fully. Crude GO TO rather than a DO-loop, because compilers use a loop counter as well as updating the index variable. Comparison runs of GNASH showed a saving of ~3% in its mass-data reading through the avoidance of DO in LSTNB alone. Crappy code for character comparison of varying lengths is avoided by using ICHAR which is for single characters only. Checking the indexing of CHARACTER variables for bounds evoked astounding stupidities, such as calculating the length of TEXT(L:L) by subtracting L from L! Comparison runs of GNASH showed a saving of ~25-30% in its mass data scanning for this, involving all its two-dozen or so single-character comparisons, not just in LSTNB.
CHARACTER*(*),INTENT(IN):: TEXT !The bumf. If there must be copy-in, at least there need not be copy back. INTEGER L !The length of the bumf. L = LEN(TEXT) !So, what is it? 1 IF (L.LE.0) GO TO 2 !Are we there yet? IF (ICHAR(TEXT(L:L)).GT.ICHAR(" ")) GO TO 2 !Control chars are regarded as spaces also. L = L - 1 !Step back one. GO TO 1 !And try again. 2 LSTNB = L !The last non-blank, possibly zero. RETURN !Unsafe to use LSTNB as a variable. END FUNCTION LSTNB !Compilers can bungle it.
SUBROUTINE LETTERCOUNT(TEXT) !Count the occurrences of A-Z. CHARACTER*(*) TEXT !The text to inspect. INTEGER I,K !Assistants. DO I = 1,LEN(TEXT) !Step through the text. K = ICHAR(TEXT(I:I)) - ICHAR("A") + 1 !This presumes that A-Z have contiguous codes! IF (K.GE.1 .AND. K.LE.26) LETTER(K) = LETTER(K) + 1 !Not so with EBCDIC!! END DO !On to the next letter. END SUBROUTINE LETTERCOUNT !Be careful with LETTER.
SUBROUTINE UPCASE(TEXT) !In the absence of an intrinsic...
Converts any lower case letters in TEXT to upper case... Concocted yet again by R.N.McLean (whom God preserve) December MM. Converting from a DO loop evades having both an iteration counter to decrement and an index variable to adjust.
CHARACTER*(*) TEXT !The stuff to be modified.
c CHARACTER*26 LOWER,UPPER !Tables. a-z may not be contiguous codes. c PARAMETER (LOWER = "abcdefghijklmnopqrstuvwxyz") c PARAMETER (UPPER = "ABCDEFGHIJKLMNOPQRSTUVWXYZ") CAREFUL!! The below relies on a-z and A-Z being contiguous, as is NOT the case with EBCDIC.
INTEGER I,L,IT !Fingers. L = LEN(TEXT) !Get a local value, in case LEN engages in oddities. I = L !Start at the end and work back.. 1 IF (I.LE.0) RETURN !Are we there yet? Comparison against zero should not require a subtraction.
c IT = INDEX(LOWER,TEXT(I:I)) !Well? c IF (IT .GT. 0) TEXT(I:I) = UPPER(IT:IT) !One to convert?
IT = ICHAR(TEXT(I:I)) - ICHAR("a") !More symbols precede "a" than "A". IF (IT.GE.0 .AND. IT.LE.25) TEXT(I:I) = CHAR(IT + ICHAR("A")) !In a-z? Convert! I = I - 1 !Back one. GO TO 1 !Inspect.. END SUBROUTINE UPCASE !Easy.
SUBROUTINE ORDERSIDE(LETTER) !Puts the letters into order. CHARACTER*(*) LETTER !The letters. INTEGER I,N,H !Assistants. CHARACTER*1 T !A scratchpad. LOGICAL CURSE !A bit. N = LEN(LETTER) !So, how many letters? H = N - 1 !Last - First, and not +1. IF (H.LE.0) RETURN !Ha ha. 1 H = MAX(1,H*10/13) !The special feature. IF (H.EQ.9 .OR. H.EQ.10) H = 11 !A twiddle. CURSE = .FALSE. !So far, so good. DO I = N - H,1,-1 !If H = 1, this is a BubbleSort. IF (LETTER(I:I).LT.LETTER(I + H:I + H)) THEN !One compare. T = LETTER(I:I) !One swap. LETTER(I:I) = LETTER(I + H:I + H) !Alas, no SWAP(A,B) LETTER(I + H:I + H) = T !Is recognised by the compiler. CURSE = .TRUE. !If once a tiger is seen... END IF !So much for that comparison. END DO !On to the next. IF (CURSE .OR. H.GT.1) GO TO 1!Another pass? END SUBROUTINE ORDERSIDE !Simple enough. SUBROUTINE ORDERBLOCKS(N,SOME) !Puts the collection of blocks into order. INTEGER N !The number of blocks. CHARACTER*(*) SOME(:) !Their lists of letters. INTEGER I,H !Assistants. CHARACTER*(LEN(SOME(1))) T !A scratchpad matching an element of SOME. LOGICAL CURSE !Since there is still no SWAP(SOME(I),SOME(I + H)). H = N - 1 !So here comes another CombSort. IF (H.LE.0) RETURN !With standard suspicion. 1 H = MAX(1,H*10/13) !This is the outer loop. IF (H.EQ.9 .OR. H.EQ.10) H = 11 !This is a fiddle. CURSE = .FALSE. !Start the next pass in hope. DO I = N - H,1,-1 !Going backwards, just for fun. IF (SOME(I).LT.SOME(I + H)) THEN !So then? T = SOME(I) !Disorder. SOME(I) = SOME(I + H) !So once again, SOME(I + H) = T !Swap the two miscreants. CURSE = .TRUE. !And remember. END IF !So much for that comparison. END DO !On to the next. IF (CURSE .OR. H.GT.1) GO TO 1!Are we there yet? END SUBROUTINE ORDERBLOCKS !Not much code, but ringing the changes is still tedious.
SUBROUTINE PLAY(N,SOME) !Mess about with the collection of blocks. INTEGER N !Their number. CHARACTER*(*) SOME(:) !Their letters. INTEGER NH,HIT(N) !A list of blocks. INTEGER B,I,J,K,L,M !Assistants. CHARACTER*1 C !A letter of the moment. L = LEN(SOME(1)) !The maximum number of letters to any block.
Cast the collection on to the floor.
WRITE (MSG,1) N,L,SOME !Announce the set as it is supplied. 1 FORMAT (I7," blocks, with at most",I2," letters:",66(1X,A))
Change the "orientation" of some blocks.
DO B = 1,N !Step through each block. CALL UPCASE(SOME(B)) !Paranoia rules. CALL ORDERSIDE(SOME(B)) !Put its letter list into order. END DO !On to the next block. WRITE (MSG,2) SOME !Reveal the orderly array. 2 FORMAT (6X,"... the letters in reverse order:",66(1X,A))
Collate the collection of blocks.
CALL ORDERBLOCKS(N,SOME) !Now order the blocks by their letters. WRITE (MSG,3) SOME !Reveal them in neato order. 3 FORMAT (7X,"... the blocks in reverse order:",66(1X,A))
Count the appearances of the letters of the alphabet.
LETTER = 0 !Enough of shuffling blocks around. DO B = 1,N !Now inspect their collective letters. CALL LETTERCOUNT(SOME(B)) !A block's worth at a go. END DO !On to the next block. SUPPLY = LETTER !Save the counts of supplied letters. WRITE (MSG,4) (CHAR(ICHAR("A") + I - 1),I = 1,26),SUPPLY !Results. 4 FORMAT (15X,"Letters of the alphabet:",26A<MS + 1>,/, !First, a line with A ... Z. 1 11X,"... number thereof supplied:",26I<MS + 1>) !Then a line of the associated counts.
Check for blocks with duplicated letters.
WRITE (MSG,5) !Announce. 5 FORMAT (8X,"Blocks with duplicated letters:",$) !Further output impends. M = 0 !No duplication found. DO B = 1,N !So step through each block. JJ:DO J = 2,L !Inspecting successive letters of the block, IF (SOME(B)(J:J).LE." ") EXIT JJ !Provided they've not run out. DO K = 1,J - 1 !To see if it has appeared earlier. IF (SOME(B)(K:K).LE." ") EXIT JJ!Reverse order means that spaces will be at the end! IF (SOME(B)(J:J).EQ.SOME(B)(K:K)) THEN !Well? M = M + 1 !A match! WRITE (MSG,6) SOME(B) !Name the block. 6 FORMAT (1X,A,$) !With further output still impending, EXIT JJ !And give up on this block. END IF !One duplicated letter is sufficient for its downfall. END DO !Next letter up. END DO JJ !On to the next letter of the block. END DO !On to the next block. CALL HIC(M) !Show the count and end the line.
Check for duplicate blocks, knowing that the array of blocks is ordered.
WRITE (MSG,7) !Announce. 7 FORMAT (21X,"Duplicated blocks:",$) !Again, leave the line dangling. K = 0 !No duplication found. B = 1 !Syncopation. 70 B = B + 1 !Advance one. IF (B.GT.N) GO TO 72 !Are we there yet? IF (SOME(B).NE.SOME(B - 1)) GO TO 70 !No match? Search on. K = K + 1 !A match is counted. WRITE (MSG,6) SOME(B) !Name it. 71 B = B + 1 !And speed through continued matching. IF (B.GT.N) GO TO 72 !Unless we're of the end. IF (SOME(B).EQ.SOME(B - 1)) GO TO 71 !Continued matching? GO TO 70 !Mismatch: resume the normal scan. 72 CALL HIC(K) !So much for that.
Check for duplicated letters across different blocks.
IF (ALL(SUPPLY.LE.1)) RETURN !Unless there are no duplicated letters. WRITE (MSG,8) !Announce. 8 FORMAT ("Duplicated letters on different blocks:",$) !More to come. K = 0 !Start another count. DO I = 1,26 !A well-known span. IF (SUPPLY(I).LE.1) CYCLE !Any duplicated letters? C = CHAR(ICHAR("A") + I - 1)!Yes. This is the character. NH = 0 !So, how many blocks contribute? DO B = 1,N !Find out. IF (INDEX(SOME(B),C).GT.0) THEN !On this block? NH = NH + 1 !Yes. HIT(NH) = B !Keep track of which. END IF !So much for that block. END DO !On to the next. IF (ANY(SOME(HIT(2:NH)) .NE. SOME(HIT(1)))) THEN !All have the same collection of letters? K = K + 1 !No! WRITE (MSG,9) C !Name the heterogenously supported letter. 9 FORMAT (A<MS + 1>,$) !Use the same spacing even though one character only. END IF !So much for that letter's search. END DO !On to the next letter. CALL HIC(K) !Finish the line with the count report. CONTAINS !This is used often enough. SUBROUTINE HIC(N) !But has very specific context. INTEGER N !The count. IF (N.LE.0) WRITE (MSG,*) "None." !Yes, we have no bananas. IF (N.GT.0) WRITE (MSG,*) N !Either way, end the line. END SUBROUTINE HIC !This service routine is not needed elsewhere. END SUBROUTINE PLAY !Look mummy! All the blockses are neatened!
LOGICAL FUNCTION CANBLOCK(WORD,N,SOME) !Can the blocks spell out the word?
Creates a move tree based on the letters of WORD and for each, the blocks available.
CHARACTER*(*) WORD !The word to spell out. INTEGER N !The number of blocks. CHARACTER*(*) SOME(:) !The blocks and their letters. INTEGER NA,AVAIL(N) !Say not the struggle naught availeth! INTEGER NMOVE(LEN(WORD)) !I need a list of acceptable blocks, INTEGER MOVE(LEN(WORD),N) !One list for each letter of WORD. INTEGER I,L,S !Assistants. CHARACTER*1 C !The letter of the moment. CANBLOCK = .FALSE. !Initial pessimism. L = LSTNB(WORD) !Ignore trailing spaces. IF (L.GT.N) RETURN !Enough blocks? LETTER = 0 !To make rabbit stew, CALL LETTERCOUNT(WORD(1:L)) !First catch your rabbit. IF (ANY(SUPPLY .LT. LETTER)) RETURN !The larder is lacking. NA = N !Prepare a list. FORALL (I = 1:N) AVAIL(I) = I !That fingers every block. I = 0 !Step through the letters of the WORD.
Chug through the letters of the WORD.
1 I = I + 1 !One letter after the other. IF (I.GT.L) GO TO 100 !Yay! We're through! C = WORD(I:I) !The letter of the moment. NMOVE(I) = 0 !No moves known at this new level. DO S = 1,NA !So, look for them amongst the available slots. IF (INDEX(SOME(AVAIL(S)),C) .GT. 0) THEN !A hit? NMOVE(I) = NMOVE(I) + 1 !Yes! Count up another possible move. MOVE(I,NMOVE(I)) = S !Remember its slot. END IF !So much for that block. END DO !On to the next. 2 IF (NMOVE(I).GT.0) THEN !Have we any moves? S = MOVE(I,NMOVE(I)) !Yes! Recover the last found. NMOVE(I) = NMOVE(I) - 1 !Uncount, as it is about to be used. IF (S.NE.NA) CALL SWAP(AVAIL(S),AVAIL(NA)) !This block is no longer available. NA = NA - 1 !Shift the boundary back. GO TO 1 !Try the next letter! END IF !But if we can't find a move at that level... I = I - 1 !Retreat a level. IF (I.LE.0) RETURN !Oh dear! S = MOVE(I,NMOVE(I) + 1) !Undo the move that had been made at this level. NA = NA + 1 !And make its block is re-available. IF (S.NE.NA) CALL SWAP(AVAIL(S),AVAIL(NA)) !Move it back. GO TO 2 !See what moves remain at this level.
Completed!
100 CANBLOCK = .TRUE. !That's a relief. END FUNCTION CANBLOCK !Some revisions might have been made. END MODULE PLAYPEN !No sand here.
USE PLAYPEN !Just so. INTEGER HAVE,TESTS !Parameters for the specified problem. PARAMETER (HAVE = 20, TESTS = 7) !Number of blocks, number of tests. CHARACTER*(MS) BLOCKS(HAVE) !Have blocks, will juggle. DATA BLOCKS/"BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS", !The specified set 1 "JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"/ !Of letter blocks. CHARACTER*8 WORD(TESTS) !Now for the specified test words. LOGICAL ANS(TESTS),T,F !And the given results. PARAMETER (T = .TRUE., F = .FALSE.) !Enable a more compact specification. DATA WORD/"A","BARK","BOOK","TREAT","COMMON","SQUAD","CONFUSE"/ !So that these DATA ANS/ T , T , F , T , F , T , T / !Can be aligned. LOGICAL YAY INTEGER I
WRITE (MSG,1) 1 FORMAT ("Arranges alphabet blocks, attending only to the ", 1 "letters on the blocks, and ignoring case and orientation.",/)
CALL PLAY(HAVE,BLOCKS) !Some fun first.
WRITE (MSG,'(/"Now to see if some words can be spelled out.")') DO I = 1,TESTS CALL UPCASE(WORD(I)) YAY = CANBLOCK(WORD(I),HAVE,BLOCKS) WRITE (MSG,*) YAY,ANS(I),YAY.EQ.ANS(I),WORD(I) END DO END
</lang> Output: the first column of T/F is the report from CANBLOCK, the second is the expected answer from the example, and the third is whether the two are in agreement.
Arranges alphabet blocks, attending only to the letters on the blocks, and ignoring case and orientation. 20 blocks, with at most 2 letters: BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM ... the letters in reverse order: OB XK QD PC NA TG RE TG QD SF WJ UH VI NA OB RE SF YL PC ZM ... the blocks in reverse order: ZM YL XK WJ VI UH TG TG SF SF RE RE QD QD PC PC OB OB NA NA Letters of the alphabet: A B C D E F G H I J K L M N O P Q R S T U V W X Y Z ... number thereof supplied: 2 2 2 2 2 2 2 1 1 1 1 1 1 2 2 2 2 2 2 2 1 1 1 1 1 1 Blocks with duplicated letters: None. Duplicated blocks: TG SF RE QD PC OB NA 7 Duplicated letters on different blocks: None. Now to see if some words can be spelled out. T T T A T T T BARK F F T BOOK T T T TREAT F F T COMMON T T T SQUAD T T T CONFUSE
FreeBASIC
<lang freebasic>' version 28-01-2019 ' compile with: fbc -s console
Dim As String blocks(1 To 20, 1 To 2) => {{"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"}}
Dim As UInteger i, x, y, b() Dim As String word, char Dim As boolean possible
Do
Read word If word = "" Then Exit Do word = UCase(word) ReDim b(1 To 20) possible = TRUE
For i = 1 To Len(word) char = Mid(word, i, 1)
For x = 1 To 20 If b(x) = 0 Then If blocks(x, 1) = char Or blocks(x, 2) = char Then b(x) = 1 Exit For End If End If Next If x = 21 Then possible = FALSE Next
Print word, possible
Loop
Data "A", "Bark", "Book", "Treat", "Common", "Squad", "Confuse", ""
' empty keyboard buffer While InKey <> "" : Wend Print : Print "hit any key to end program" Sleep End</lang>
- Output:
A true BARK true BOOK false TREAT true COMMON false SQUAD true CONFUSE true
Gambas
Click this link to run this code <lang gambas>Public Sub Main() Dim sCheck As String[] = ["A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"] Dim sBlock As String[] = ["BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"] Dim sList As New String[] Dim siCount, siLoop As Short Dim sTemp, sAnswer As String
For Each sTemp In sCheck
sAnswer = "" sList = sBlock.Copy() For siCount = 1 To Len(sTemp) For siLoop = 0 To sList.Max If InStr(sList[siLoop], Mid(sTemp, siCount, 1)) Then sList.Extract(siLoop, 1) sAnswer &= Mid(sTemp, siCount, 1) Break Endif Next Next
If sAnswer = sTemp Then Print sTemp & " - True" Else Print sTemp & " - False" End If
Next
End</lang> Output:
A - True BARK - True BOOK - False TREAT - True COMMON - False SQUAD - True CONFUSE - True
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)
Or, in terms of the bind operator:
<lang haskell>import Data.Char (toUpper) import Data.List (delete)
ABC PROBLEM ----------------------
spellWith :: [String] -> String -> String spellWith _ [] = [[]] spellWith blocks (x : xs) = blocks >>= go
where go b | x `elem` b = (b :) <$> spellWith (delete b blocks) xs | otherwise = []
TEST -------------------------
main :: IO () main =
mapM_ ( print . ((,) <*>) (not . null . spellWith blocks . fmap toUpper) ) [ "", "A", "BARK", "BoOK", "TrEAT", "COmMoN", "SQUAD", "conFUsE" ]
blocks :: [String] blocks =
words $ "BO XK DQ CP NA GT RE TG QD FS JW" <> " HU VI AN OB ER FS LY PC ZM"</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, three of the candidates are valid, for this trivial example.)
Java
<lang java5>import java.util.Arrays; import java.util.Collections; import java.util.List;
public class ABC {
public static void main(String[] args) { List<String> blocks = Arrays.asList( "BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM");
for (String word : Arrays.asList("", "A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE")) { System.out.printf("%s: %s%n", word.isEmpty() ? "\"\"" : word, canMakeWord(word, blocks)); } }
public static boolean canMakeWord(String word, List<String> blocks) { if (word.isEmpty()) return true;
char c = word.charAt(0); for (int i = 0; i < blocks.size(); i++) { String b = blocks.get(i); if (b.charAt(0) != c && b.charAt(1) != c) continue; Collections.swap(blocks, 0, i); if (canMakeWord(word.substring(1), blocks.subList(1, blocks.size()))) return true; Collections.swap(blocks, 0, i); }
return false; }
}</lang>
- Output:
"": true A: true BARK: true book: false treat: true COMMON: false SQuAd: true CONFUSE: true
JavaScript
ES5
Imperative
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
<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
Imperative
<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
Functional
<lang JavaScript>(() => {
"use strict";
// ------------------- ABC BLOCKS --------------------
// spellWith :: [(Char, Char)] -> [Char] -> (Char, Char) const spellWith = blocks => wordChars => !Boolean(wordChars.length) ? [ [] ] : (() => { const [x, ...xs] = wordChars;
return blocks.flatMap( b => b.includes(x) ? ( spellWith( deleteBy( p => q => (p[0] === q[0]) && ( p[1] === q[1] ) )(b)(blocks) )(xs) .flatMap(bs => [b, ...bs]) ) : [] ); })();
// ---------------------- TEST ----------------------- const main = () => { const blocks = ( "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM" ).split(" ");
return [ "", "A", "BARK", "BoOK", "TrEAT", "COmMoN", "SQUAD", "conFUsE" ] .map( x => JSON.stringify([ x, !Boolean( spellWith(blocks)( [...x.toLocaleUpperCase()] ) .length ) ]) ) .join("\n"); };
// ---------------- GENERIC FUNCTIONS ----------------
// deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] const deleteBy = fEq => x => { const go = xs => Boolean(xs.length) ? ( fEq(x)(xs[0]) ? ( xs.slice(1) ) : [xs[0], ...go(xs.slice(1))] ) : [];
return go; };
// MAIN --- return main();
})();</lang>
- Output:
["",true] ["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
Jsish
Based on Javascript ES5 imperative solution. <lang javascript>#!/usr/bin/env jsish /* ABC problem, in Jsish. Can word be spelled with the given letter blocks. */ 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) {
var re = /([a-z]*)/i; if (word !== re.exec(word)[0]) return false; for (var i = 0; i < word.length; i++) { var letter = word.charAt(i); var length = blocks.length; // trying both sides var reg = new RegExp("([a-z]"+letter + "|" + letter+"[a-z])", "i"); // remove block once a letter is used blocks = blocks.replace(reg, ""); if (blocks.length === length) return false; } return true;
};
var words = [ "A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE" ];
puts("Using blocks:", blocks); for(var i = 0; i<words.length; i++)
puts(CheckWord(blocks, words[i]) ? "can" : "can't", "spell", words[i]);
/*
!EXPECTSTART!
Using blocks: BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM can spell A can spell BARK can't spell BOOK can spell TREAT can't spell COMMON can spell SQUAD can spell CONFUSE
!EXPECTEND!
- /</lang>
- Output:
prompt$ jsish ABCProblem.jsi Using blocks: BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM can spell A can spell BARK can't spell BOOK can spell TREAT can't spell COMMON can spell SQUAD can spell CONFUSE prompt$ jsish -u ABCProblem.jsi [PASS] ABCProblem.jsi
Julia
<lang julia>using Printf
function abc(str::AbstractString, list)
isempty(str) && return true for i in eachindex(list) str[end] in list[i] && any([abc(str[1:end-1], deleteat!(copy(list), i))]) && return true end return false
end
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</lang>
- Output:
A | true BARK | true BOOK | false TREAT | true COMMON | false SQUAD | true CONFUSE | true
Kotlin
<lang scala>object ABC_block_checker {
fun run() { println("\"\": " + blocks.canMakeWord("")) 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.isEmpty()) return true
val c = word.first().toUpperCase() 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 }
private val blocks = arrayOf( "BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM" ) private val words = arrayOf("A", "BARK", "book", "treat", "COMMON", "SQuAd", "CONFUSE")
}
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
Liberty BASIC
Recursive solution
<lang lb> print "Rosetta Code - ABC problem (recursive solution)" print blocks$="BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM" data "A" data "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE" data "XYZZY"
do
read text$ if text$="XYZZY" then exit do print ">>> can_make_word("; chr$(34); text$; chr$(34); ")" if canDo(text$,blocks$) then print "True" else print "False"
loop while 1 print "Program complete." end
function canDo(text$,blocks$)
'endcase if len(text$)=1 then canDo=(instr(blocks$,text$)<>0): exit function 'get next letter ltr$=left$(text$,1) 'cut if instr(blocks$,ltr$)=0 then canDo=0: exit function 'recursion text$=mid$(text$,2) 'rest 'loop by all word in blocks. Need to make "newBlocks" - all but taken 'optimisation: take only fitting blocks wrd$="*" i=0 while wrd$<>"" i=i+1 wrd$=word$(blocks$, i) if instr(wrd$, ltr$) then 'newblocks without wrd$ pos=instr(blocks$,wrd$) newblocks$=left$(blocks$, pos-1)+mid$(blocks$, pos+3) canDo=canDo(text$,newblocks$) 'first found cuts if canDo then exit while end if wend
end function </lang>
- Output:
Rosetta Code - ABC problem (recursive solution) >>> 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 Program complete.
Procedural solution
<lang lb> print "Rosetta Code - ABC problem (procedural solution)" print w$(1)="A" w$(2)="BARK" w$(3)="BOOK" w$(4)="TREAT" w$(5)="COMMON" w$(6)="SQUAD" w$(7)="CONFUSE"
for x=1 to 7
print ">>> can_make_word("; chr$(34); w$(x); chr$(34); ")" if CanMakeWord(w$(x)) then print "True" else print "False"
next x print "Program complete." end
function CanMakeWord(x$) global DoneWithWord, BlocksUsed, LetterOK, Possibility dim block$(20,2), block(20,2) 'numeric blocks, col 0 flags used block block(1,1)=asc("B")-64: block(1,2)=asc("O")-64 block(2,1)=asc("X")-64: block(2,2)=asc("K")-64 block(3,1)=asc("D")-64: block(3,2)=asc("Q")-64 block(4,1)=asc("C")-64: block(4,2)=asc("P")-64 block(5,1)=asc("N")-64: block(5,2)=asc("A")-64 block(6,1)=asc("G")-64: block(6,2)=asc("T")-64 block(7,1)=asc("R")-64: block(7,2)=asc("E")-64 block(8,1)=asc("T")-64: block(8,2)=asc("G")-64 block(9,1)=asc("Q")-64: block(9,2)=asc("D")-64 block(10,1)=asc("F")-64: block(10,2)=asc("S")-64 block(11,1)=asc("J")-64: block(11,2)=asc("W")-64 block(12,1)=asc("H")-64: block(12,2)=asc("U")-64 block(13,1)=asc("V")-64: block(13,2)=asc("I")-64 block(14,1)=asc("A")-64: block(14,2)=asc("N")-64 block(15,1)=asc("O")-64: block(15,2)=asc("B")-64 block(16,1)=asc("E")-64: block(16,2)=asc("R")-64 block(17,1)=asc("F")-64: block(17,2)=asc("S")-64 block(18,1)=asc("L")-64: block(18,2)=asc("Y")-64 block(19,1)=asc("P")-64: block(19,2)=asc("C")-64 block(20,1)=asc("Z")-64: block(20,2)=asc("M")-64
x$=upper$(x$) for x=1 to len(x$)
y$=mid$(x$,x,1) if y$>="A" and y$<="Z" then w$=w$+y$
next x if w$="" then exit function DoneWithWord=0: BlocksUsed=0 l=len(w$) dim LetterOK(l) dim alphabet(26,1) 'clear letter-usage array for x=1 to 20 'load block letters into letter-usage array col 0
alphabet(block(x,1),0)+=1 alphabet(block(x,2),0)+=1
next x for x=1 to l 'load current word into letter-usage aray col 1
wl$=mid$(w$,x,1): w=asc(wl$)-64 alphabet(w,1)+=1
next x
for x=1 to 26 ' test for more of any letter in the word than in the blocks
if alphabet(x,1)>alphabet(x,0) then exit function
next x
[NextLetter] if wl<l then wl=wl+1 else goto [DoneWithWord] wl$=mid$(w$,wl,1): w=asc(wl$)-64 LetterOK=0 ' if there's only one of the letter in the blocks then you must use that block if alphabet(w,0)=1 then
call OnlyBlock w LetterOK(wl)=1 if DoneWithWord then goto [DoneWithWord] else goto [NextLetter]
end if ' if more than one of the letter in the blocks, then try to use one that has ' an unused letter on other side (a "Free Block") call FindFreeBlock w if LetterOK then LetterOK(wl)=1 goto [NextLetter]
[DoneWithWord] if BlocksUsed=l then CanMakeWord=1: exit function if DoneWithWord then exit function for x=1 to l
if not(LetterOK(x)) then NumericLetter=asc(mid$(w$,x,1))-64 LetterOK=0 call OnlyBlock NumericLetter if LetterOK then LetterOK(x)=1 else exit for end if
next x goto [DoneWithWord] end function
sub OnlyBlock NumericLetter
for x=1 to 20 if (block(x, 1)=NumericLetter or block(x, 2)=NumericLetter) _ and block(x, 0)=0 then call UseBlock x, NumericLetter exit sub end if next x DoneWithWord=1
end sub
sub FindFreeBlock NumericLetter
Possibility=0 for x=1 to 20 if block(x, 0)=0 then 'block not used if block(x,1)=NumericLetter then if alphabet(block(x,2),1)=0 then call UseBlock x, NumericLetter exit sub end if Possibility=Possibility+1 end if if block(x,2)=NumericLetter then if alphabet(block(x,1),1)=0 then call UseBlock x, NumericLetter exit sub end if Possibility=Possibility+1 end if end if next x
end sub
sub UseBlock BlockNumber, NumericLetter
block(BlockNumber, 0)=1 'Mark block as used BlocksUsed=BlocksUsed+1 LetterOK=1
end sub </lang>
- Output:
Rosetta Code - ABC problem (procedural solution) >>> 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 Program complete.
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
M2000 Interpreter
We use a subroutine inside a module. Subs are in the same namespace as the module which call them. Subs may exist in the end of module, or in the parent module (which module defined). We have to use Local to define new variables which shadow any module variable. When a sub exit all new variables which made there erased. Modules run on objects which "interprets" code, and subs use modules objects, so they are lighter than modules. A module hold a separate return stack for subs, gosub and for next structures ( a for {} use process stack, and is twice faster as the simple For Next). This return stack is a stack object, which is a collection of objects in heap, so we can use Recursion.Limit 100000 to set limit to 100000 calls for subs. Here we use a for next and a subroutine, using modules dedicated return stack. We can call can_make_word() using name or using Gosub. Gosub can call subs as labels, and expect Return to return from sub. These routines are more lighter than subs, because they run as code is in module, and any new variable stay until module exit. So we never make local variables or if we want locals we have to use Fopr This { }, the block for temporary definitions.
<lang M2000 Interpreter>
Module ABC {
can_make_word("A") can_make_word("BaRk") can_make_word("BOOK") can_make_word("TREAT") can_make_word("CommoN") can_make_word("SQUAD") Gosub can_make_word("CONFUSE") ' we can use Gosub before Sub can_make_word(c$) local b$=ucase$(c$) local i, a$="BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM", m for i=1 to len(b$) m=Instr(a$,mid$(b$, i, 1)) If m=0 Then Exit for Insert binary.or(m-1, 1),2 a$="" ' delete 2 chars Next i Print c$, m<>0 End Sub
} ABC </lang>
- Output:
A True BaRk True BOOK False TREAT True CommoN False SQUAD True CONFUSE True
Maple
<lang maple>canSpell := proc(w) local blocks, i, j, word, letterFound; blocks := Array([["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"]]);
word := StringTools[UpperCase](convert(w, string)); for i to length(word) do letterFound := false; for j to numelems(blocks)/2 do if not letterFound and (substring(word, i) = blocks[j,1] or substring(word, i) = blocks[j,2]) then blocks[j,1] := undefined; blocks[j,2] := undefined; letterFound := true; end if; end do; if not letterFound then return false; end if; end do; return true; end proc:
seq(printf("%a: %a\n", i, canSpell(i)), i in [a, Bark, bOok, treat, COMMON, squad, confuse]);</lang>
- Output:
a: true Bark: true bOok: false treat: true COMMON: false squad: true 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 / Octave
<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.
Mercury
<lang Mercury>:- module abc.
- - interface.
- - import_module io.
- - pred main(io::di, io::uo) is det.
- - implementation.
- - import_module list, string, char.
- - type block == {char, char}.
- - pred take(char, list(block), list(block)).
- - mode take(in, in, out) is nondet.
take(C, !Blocks) :-
list.delete(!.Blocks, {A, B}, !:Blocks), ( A = C ; B = C ).
- - pred can_make_word(list(char)::in, list(block)::in) is semidet.
can_make_word([], _). can_make_word([C|Cs], !.Blocks) :-
take(C, !Blocks), can_make_word(Cs, !.Blocks).
main(!IO) :-
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'} ], Words = ["A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"], foldl((pred(W::in, !.IO::di, !:IO::uo) is det :- P = can_make_word(to_char_list(W), Blocks), io.format("can_make_word(""%s"") :- %s.\n", [s(W), s(if P then "true" else "fail")], !IO)), Words, !IO).</lang>
Note that 'P', in the foldl near the end, is not a boolean variable, but a zero-arity currying of can_make_word (i.e., it's a 'lambda' that takes no arguments and then calls can_make_word with all of the already-supplied arguments).
MiniScript
<lang MiniScript>allBlocks = ["BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"]
swap = function(list, index1, index2)
tmp = list[index1] list[index1] = list[index2] list[index2] = tmp
end function
canMakeWord = function(str, blocks)
if str == "" then return true c = str[0].upper for i in range(0, blocks.len - 1) bl = blocks[i] if c != bl[0] and c != bl[1] then continue swap blocks, 0, i if canMakeWord(str[1:], blocks[1:]) then return true swap blocks, 0, i end for return false
end function
for val in ["", "A", "BARK", "book", "Treat", "COMMON", "sQuAD", "CONFUSE"]
out = """""" if val.len != 0 then out = val print out + ": " + canMakeWord(val, allBlocks)
end for </lang>
Nim
<lang nim>import std / strutils
func canMakeWord(blocks: seq[string]; word: string): bool =
if blocks.len < word.len: return false if word.len == 0: return true
let ch = word[0].toUpperAscii for i, pair in blocks: if ch in pair and (blocks[0..<i] & blocks[i+1..^1]).canMakeWord(word[1..^1]): return true
proc main =
for (blocks, words) in [ ("BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM".splitWhitespace, @["A", "bArK", "BOOK", "treat", "common", "sQuAd", "CONFUSE"]), ("AB AB AC AC".splitWhitespace, @["ABBa"]), ("US TZ AO QA".splitWhitespace, @["Auto"]) ]: echo "Using the blocks ", blocks.join(" ") for word in words: echo " can we make the word '$#'? $#" % [ word, if blocks.canMakeWord(word): "yes" else: "no"] echo()
when isMainModule: main()</lang>
- Output:
Using the blocks BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM can we make the word 'A'? yes can we make the word 'bArK'? yes can we make the word 'BOOK'? no can we make the word 'treat'? yes can we make the word 'common'? no can we make the word 'sQuAd'? yes can we make the word 'CONFUSE'? yes Using the blocks AB AB AC AC can we make the word 'ABBa'? yes Using the blocks US TZ AO QA can we make the word 'Auto'? 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>import: mapping
["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 empty? ifTrue: [ true return ] blocks size loop: i [ w first >upper blocks at(i) include? 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]) . [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
Order
<lang Order>#include <order/interpreter.h>
- include <order/lib.h>
// Because of technical limitations, characters within a "string" must be separated by white spaces. // For the sake of simplicity, only upper-case characters are supported here.
// A few lines of boiler-plate oriented programming are needed to enable character parsing and comparison.
- define ORDER_PP_TOKEN_A (A)
- define ORDER_PP_TOKEN_B (B)
- define ORDER_PP_TOKEN_C (C)
- define ORDER_PP_TOKEN_D (D)
- define ORDER_PP_TOKEN_E (E)
- define ORDER_PP_TOKEN_F (F)
- define ORDER_PP_TOKEN_G (G)
- define ORDER_PP_TOKEN_H (H)
- define ORDER_PP_TOKEN_I (I)
- define ORDER_PP_TOKEN_J (J)
- define ORDER_PP_TOKEN_K (K)
- define ORDER_PP_TOKEN_L (L)
- define ORDER_PP_TOKEN_M (M)
- define ORDER_PP_TOKEN_N (N)
- define ORDER_PP_TOKEN_O (O)
- define ORDER_PP_TOKEN_P (P)
- define ORDER_PP_TOKEN_Q (Q)
- define ORDER_PP_TOKEN_R (R)
- define ORDER_PP_TOKEN_S (S)
- define ORDER_PP_TOKEN_T (T)
- define ORDER_PP_TOKEN_U (U)
- define ORDER_PP_TOKEN_V (V)
- define ORDER_PP_TOKEN_W (W)
- define ORDER_PP_TOKEN_X (X)
- define ORDER_PP_TOKEN_Y (Y)
- define ORDER_PP_TOKEN_Z (Z)
- define ORDER_PP_SYM_A(...) __VA_ARGS__
- define ORDER_PP_SYM_B(...) __VA_ARGS__
- define ORDER_PP_SYM_C(...) __VA_ARGS__
- define ORDER_PP_SYM_D(...) __VA_ARGS__
- define ORDER_PP_SYM_E(...) __VA_ARGS__
- define ORDER_PP_SYM_F(...) __VA_ARGS__
- define ORDER_PP_SYM_G(...) __VA_ARGS__
- define ORDER_PP_SYM_H(...) __VA_ARGS__
- define ORDER_PP_SYM_I(...) __VA_ARGS__
- define ORDER_PP_SYM_J(...) __VA_ARGS__
- define ORDER_PP_SYM_K(...) __VA_ARGS__
- define ORDER_PP_SYM_L(...) __VA_ARGS__
- define ORDER_PP_SYM_M(...) __VA_ARGS__
- define ORDER_PP_SYM_N(...) __VA_ARGS__
- define ORDER_PP_SYM_O(...) __VA_ARGS__
- define ORDER_PP_SYM_P(...) __VA_ARGS__
- define ORDER_PP_SYM_Q(...) __VA_ARGS__
- define ORDER_PP_SYM_R(...) __VA_ARGS__
- define ORDER_PP_SYM_S(...) __VA_ARGS__
- define ORDER_PP_SYM_T(...) __VA_ARGS__
- define ORDER_PP_SYM_U(...) __VA_ARGS__
- define ORDER_PP_SYM_V(...) __VA_ARGS__
- define ORDER_PP_SYM_W(...) __VA_ARGS__
- define ORDER_PP_SYM_X(...) __VA_ARGS__
- define ORDER_PP_SYM_Y(...) __VA_ARGS__
- define ORDER_PP_SYM_Z(...) __VA_ARGS__
/// 8blocks_lexer (string) : Seq String -> Seq (Seq Sym)
- define ORDER_PP_DEF_8blocks_lexer ORDER_PP_FN \
(8fn (8S \
,8seq_map (8tokens_to_seq \ ,8S \ ) \ ) \
)
// Keying the blocks makes filtering them way more efficient than by comparing their letters. /// 8seq_keyed (sequence) : Seq a -> Seq (Pair Num a)
- define ORDER_PP_DEF_8seq_keyed ORDER_PP_FN \
(8fn (8S \
,8stream_to_seq (8stream_pair_with (8pair \ ,8stream_of_naturals \ ,8seq_to_stream (8S) \ ) \ ) \ ) \
)
/// 8abc_internal (blocks, word) : Seq (Pair Num (Seq Token)) -> Seq Token -> Bool
- define ORDER_PP_DEF_8abc_internal ORDER_PP_FN \
(8fn (8B, 8W \
,8if (8seq_is_nil (8W) \ ,8true \ ,8lets ((8C, 8seq_head (8W)) \ (8S, 8seq_filter (8chain (8seq_exists (8same (8C)) \ ,8tuple_at_1 \ ) \ ,8B \ ) \ ) \ (8T, 8seq_map (8chain (8flip (8seq_filter \ ,8B \ ) \ ,8bin_pr (8not_eq \ ,8tuple_at_0 \ ) \ ) \ ,8S \ ) \ ) \ ,8seq_exists (8flip (8abc_internal \ ,8seq_tail (8W) \ ) \ ,8T \ ) \ ) \ ) \ ) \
)
/// 8abc (blocks, word) : Seq (String) -> String -> Bool
- define ORDER_PP_DEF_8abc ORDER_PP_FN \
(8fn (8B, 8W \
,8abc_internal (8seq_keyed (8blocks_lexer (8B)) \ ,8tokens_to_seq (8W) \ ) \ ) \
)
- define ORDER_PP_DEF_8blocks ORDER_PP_CONST ( \
(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) \
)
ORDER_PP (8seq_map (8step (8pair (8identity
,8abc (8blocks) ) ) ,8quote ((A) (B A R K) (B O O K) (T R E A T) (C O M M O N) (S Q U A D) (C O N F U S E) ) )
)
</lang>
- Output:
((A,8true))((B A R K,8true))((B O O K,8false))((T R E A T,8true))((C O M M O N,8false))((S Q U A D,8true))((C O N F U S E,8true))
PARI/GP
<lang parigp>BLOCKS = "BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"; WORDS = ["A","Bark","BOOK","Treat","COMMON","SQUAD","conFUSE"];
can_make_word(w) = check(Vecsmall(BLOCKS), Vecsmall(w))
check(B,W,l=1,n=1) = {
if (l > #W, return(1), n > #B, return(0)); forstep (i = 1, #B-2, 2, if (B[i] != bitand(W[l],223) && B[i+1] != bitand(W[l],223), next()); B[i] = B[i+1] = 0; if (check(B, W, l+1, n+2), return(1)) ); 0
}
for (i = 1, #WORDS, printf("%s\t%d\n", WORDS[i], can_make_word(WORDS[i])));</lang>
Output:
A 1 Bark 1 BOOK 0 Treat 1 COMMON 0 SQUAD 1 conFUSE 1
Pascal
<lang Pascal>
- !/usr/bin/instantfpc
//program ABCProblem;
{$mode objfpc}{$H+}
uses SysUtils, Classes;
const
// every couple of chars is a block // remove one by replacing its 2 chars by 2 spaces Blocks = 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM'; BlockSize = 3;
function can_make_word(Str: String): boolean; var
wkBlocks: string = Blocks; c: Char; iPos : Integer;
begin
// all chars to uppercase Str := UpperCase(Str); Result := Str <> ; if Result then begin for c in Str do begin iPos := Pos(c, wkBlocks); if (iPos > 0) then begin // Char found wkBlocks[iPos] := ' '; // Remove the other face if (iPos mod BlockSize = 1) then wkBlocks[iPos + 1] := ' ' else wkBlocks[iPos - 1] := ' '; end else begin // missed Result := False; break; end; end; end; // Debug... //WriteLn(Blocks); //WriteLn(wkBlocks);
End;
procedure TestABCProblem(Str: String); const
boolStr : array[boolean] of String = ('False', 'True');
begin
WriteLn(Format('>>> can_make_word("%s")%s%s', [Str, LineEnding, boolStr[can_make_word(Str)]]));
End;
begin
TestABCProblem('A'); TestABCProblem('BARK'); TestABCProblem('BOOK'); TestABCProblem('TREAT'); TestABCProblem('COMMON'); TestABCProblem('SQUAD'); TestABCProblem('CONFUSE');
END.</lang>
- Output:
./ABCProblem.pas >>> 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
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>
Regex based alternate
<lang perl>#!/usr/bin/perl
use strict; # https://rosettacode.org/wiki/ABC_Problem use warnings;
printf "%30s %s\n", $_, can_make_word( $_,
'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM' ) for qw( A BARK BOOK TREAT COMMON SQUAD CONFUSE );
sub can_make_word
{ my ($word, $blocks) = @_; my $letter = chop $word or return 'True'; can_make_word( $word, $` . $' ) eq 'True' and return 'True' while $blocks =~ /\w?$letter\w?/gi; return 'False'; }</lang>
- Output:
A True BARK True BOOK False TREAT True COMMON False SQUAD True CONFUSE True
Phix
Recursive solution which also solves the extra problems on the discussion page.
sequence blocks, words, used function ABC_Solve(sequence word, integer idx) integer ch, res = 0 if idx>length(word) then res = 1 -- or: res = length(word)>0 -- (if "" -> false desired) 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 tests = {{{"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"}}, {{"US","TZ","AO","QA"},{"AuTO"}}, {{"AB","AB","AC","AC"},{"abba"}}} for i=1 to length(tests) do {blocks,words} = tests[i] used = repeat(0,length(blocks)) for j=1 to length(words) do printf(1,"%s: %t\n",{words[j],ABC_Solve(upper(words[j]),1)}) end for end for
- Output:
: true A: true BarK: true BOOK: false TrEaT: true COMMON: false SQUAD: true CONFUSE: true AuTO: true abba: 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
Picat
Showing both a Picat style version (check_word/2) and a Prolog style recursive version (check_word2/2). go2/0 generates all possible solutions (using fail/0) to backtrack. <lang Picat>go =>
test_it(check_word), test_it(check_word2), nl.
% Get all possible solutions (via fail) go2 ?=>
test_version(check_word2), fail, nl.
go2 => true.
% % Test a version. % test_it(Pred) =>
println(testing=Pred), Blocks = findall([A,B], block(A,B)), Words = findall(W,word(W)), foreach(Word in Words) println(word=Word), ( call(Pred,Word,Blocks) ; println("Cannot make word.")), nl end, nl.
% % Picat style: Using nth/3 for getting the chars % check_word(Word, Blocks) =>
WordC = atom_chars(Word), % convert atom to string WordLen = length(WordC), X = new_list(WordLen), Pos = new_list(WordLen), foreach(I in 1..WordLen) % find a character at the specific position nth(X[I],Blocks,XI), nth(Pos[I],XI, WordC[I]) end, alldiff(X), % ensure unique selection foreach(I in 1..WordLen) println([WordC[I], Blocks[X[I]]]) end, nl.
% % Prolog style (recursive) version using select/3. % (where we don't have to worry about duplicate blocks) % check_word2(Word, Blocks) :-
pick_block(atom_chars(Word),Blocks,[],X), println(X).
pick_block([], _,Res,Res). pick_block([C|WordRest], Blocks, Res1,[Block|Res]) :-
% pick (non-deterministically) one of the blocks select(Block,Blocks,BlocksRest), membchk(C,Block), pick_block(WordRest,BlocksRest,Res1,Res).
% % alldiff(L): % ensure that all elements in L are different % alldiff([]). alldiff([_]). alldiff([H|T]) :-
neq(H,T), alldiff(T).
neq(_,[]). neq(X,[H|T]) :-
X != H, neq(X,T).
% The words to check. word(a). word(bark). word(book). word(treat). word(common). word(squad). word(confuse). word(auto). word(abba). word(coestablishment). word(schoolmastering).
% The blocks block(b,o). block(x,k). block(d,q). block(c,p). block(n,a). block(g,t). block(r,e). block(t,g). block(q,d). block(f,s). block(j,w). block(h,u). block(v,i). block(a,n). block(o,b). block(e,r). block(f,s). block(l,y). block(p,c). block(z,m). </lang>
- Output:
testing = check_word word = a [a,na] word = bark [b,bo] [a,na] [r,re] [k,xk] word = book Cannot make word. word = treat [t,gt] [r,re] [e,er] [a,na] [t,tg] word = common Cannot make word. word = squad [s,fs] [q,dq] [u,hu] [a,na] [d,qd] word = confuse [c,cp] [o,bo] [n,na] [f,fs] [u,hu] [s,fs] [e,re] word = auto [a,na] [u,hu] [t,gt] [o,bo] word = abba [a,na] [b,bo] [b,ob] [a,an] word = coestablishment [c,cp] [o,bo] [e,re] [s,fs] [t,gt] [a,na] [b,ob] [l,ly] [i,vi] [s,fs] [h,hu] [m,zm] [e,er] [n,an] [t,tg] word = schoolmastering [s,fs] [c,cp] [h,hu] [o,bo] [o,ob] [l,ly] [m,zm] [a,na] [s,fs] [t,gt] [e,re] [r,er] [i,vi] [n,an] [g,tg] testing = check_word2 word = a [na] word = bark [bo,na,re,xk] word = book Cannot make word. word = treat [gt,re,er,na,tg] word = common Cannot make word. word = squad [fs,dq,hu,na,qd] word = confuse [cp,bo,na,fs,hu,fs,re] word = auto [na,hu,gt,bo] word = abba [na,bo,ob,an] word = coestablishment [cp,bo,re,fs,gt,na,ob,ly,vi,fs,hu,zm,er,an,tg] word = schoolmastering [fs,cp,hu,bo,ob,ly,zm,na,fs,gt,re,er,vi,an,tg]
PicoLisp
Mapping and recursion. <lang PicoLisp>(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) while(flag = true); 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.
PL/M
<lang plm>100H:
/* ABC PROBLEM ON $-TERMINATED STRING */ CAN$MAKE$WORD: PROCEDURE (STRING) BYTE;
DECLARE STRING ADDRESS, CHAR BASED STRING BYTE; DECLARE CONST$BLOCKS DATA ('BOKXDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM'); DECLARE I BYTE, BLOCKS (40) BYTE; DO I=0 TO 39; /* MAKE COPY OF BLOCKS */ BLOCKS(I) = CONST$BLOCKS(I); END; STEP: DO WHILE CHAR <> '$'; DO I=0 TO 39; /* FIND BLOCK WITH CURRENT CHAR */ IF BLOCKS(I) = CHAR THEN DO; /* FOUND IT */ BLOCKS(I) = 0; /* CLEAR OUT BOTH LETTERS ON BLOCK */ BLOCKS(I XOR 1) = 0; STRING = STRING + 1; GO TO STEP; /* NEXT CHARACTER */ END; END; RETURN 0; /* NO BLOCK WITH LETTER */ END; RETURN 1; /* WE FOUND THEM ALL */
END CAN$MAKE$WORD;
/* CP/M BDOS CALL */ BDOS: PROCEDURE (FN, ARG);
DECLARE FN BYTE, ARG ADDRESS; GO TO 5;
END BDOS;
PRINT: PROCEDURE (STRING);
DECLARE STRING ADDRESS; CALL BDOS(9, STRING);
END PRINT;
/* TEST SEVERAL STRINGS */ DECLARE TEST (7) ADDRESS, I BYTE; TEST(0) = .'A$'; TEST(1) = .'BARK$'; TEST(2) = .'BOOK$'; TEST(3) = .'TREAT$'; TEST(4) = .'COMMON$'; TEST(5) = .'SQUAD$'; TEST(6) = .'CONFUSE$';
DO I = 0 TO LAST(TEST);
CALL PRINT(TEST(I)); CALL PRINT(.': $'); IF CAN$MAKE$WORD(TEST(I)) THEN CALL PRINT(.'YES$'); ELSE CALL PRINT(.'NO$'); CALL PRINT(.(13,10,'$'));
END;
CALL BDOS(0,0); EOF</lang>
- Output:
A: YES BARK: YES BOOK: NO TREAT: YES COMMON: NO SQUAD: YES CONFUSE: YES
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 letters.s = #LETTERS, buffer.s Define index1.i, index2.i Define match.b 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>#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> Note that this code is broken, e.g., it won't work when blocks = [("A", "B"), ("A","C")] and the word is "AB", where the answer should be True, but the code returns False. 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']
q
The possibility of ‘backtracking’, discussed in the FORTRAN solution above (and not tested by the example set) makes this a classic tree search: wherever there is a choice of blocks from which to pick the next letter, each choice must be tested. <lang q>BLOCKS:string`BO`XK`DQ`CP`NA`GT`RE`TG`QD`FS`JW`HU`VI`AN`OB`ER`FS`LY`PC`ZM WORDS:string`A`BARK`BOOK`TREAT`COMMON`SQUAD`CONFUSE
cmw:{[s;b] / [str;blocks]
$[0=count s; 1b; / empty string not any found:any each b=s 0; 0b; / cannot proceed any(1_s).z.s/:b(til count b)except/:where found] }</lang>
- Output:
<lang q>q)WORDS cmw\:BLOCKS
1101011b</lang>
The first expression tests whether the string s
is empty. If so, the result is true. This matches two cases: either the string is empty and can be made from any set of blocks; or all its letters have been matched and there is nothing more to check.
The second expression looks in the available blocks b
for the first letter of s
: the boolean vector found
flags any hits. If there are none, the result is false: the string cannot be completed from the available blocks.
The last line searches further. The expression til count b
indexes the remaining blocks; and where found
are the indexes that have the next letter. The derived function except/:
yields a list: each item is a copy of the list of indexes til count b
, with one of the found
indexes removed. The list of blocks b
is applied to each of these index lists; the result is multiple versions of the list of blocks; each has had a different block removed. The cmw
function is applied to each of these with the truncated string 1_s
. (The expression .z.s
refers to the currently-running function, so cmw
does not need to know its own name.) The result of these calls is a boolean vector; aggregator any
reports if any have succeeded in completing the string.
To meet the requirement for case-insensitivity and to display the results, apply the above within a wrapper. <lang q>Words:string`A`bark`BOOK`Treat`COMMON`squad`CONFUSE cmwi:{(`$x), `false`true cmw . upper each(x;y) }</lang>
- Output:
<lang q>q)Words cmwi\:BLOCKS A true bark true BOOK false Treat true COMMON false squad true CONFUSE true</lang>
Quackery
Iterative, without backtracking
See note in the FORTRAN solution and elsewhere re: backtracking. Fails the ABBA test, see "Greedy Algorithm" in the discussion for this page.
This solution assumes the constraint that if a letter appears on more than one block those blocks are identical (as in the example set) so backtracking is not required.
<lang Quackery>[ $ "BOXKDQCPNAGTRETGQDFS"
$ "JWHUVIANOBERFSLYPCZM" join ] constant is blocks ( --> $ )
[ -2 &
tuck pluck drop swap pluck drop ] is remove2 ( $ n --> $ )
[ iff [ say "True" ]
else [ say "False" ] ] is echotruth ( b --> )
[ true blocks rot
witheach [ upper over find 2dup swap found iff remove2 else [ drop dip not conclude ] ] drop echotruth ] is can_make_word ( $ --> )</lang>
Testing in the Quackery shell:
/O> $ "A" can_make_word ... True Stack empty. /O> $ "BARK" can_make_word ... True Stack empty. /O> $ "BOOK" can_make_word ... False Stack empty. /O> $ "TREAT" can_make_word ... True Stack empty. /O> $ "COMMON" can_make_word ... False Stack empty. /O> $ "SQUAD" can_make_word ... True Stack empty. /O> $ "CONFUSE" can_make_word ... True Stack empty.
Recursive, with backtracking
See note in the FORTRAN solution and elsewhere re: backtracking. Passes the ABBA test, see "Greedy Algorithm" in the discussion for this page.
This solution does not assume the constraint that if a letter appears on more than one block those blocks are identical (as in the example set) so backtracking is required.
<lang Quackery>[ ' [ 0 ] swap
witheach [ over -1 peek + join ] behead drop ] is accumulate ( [ --> [ )
[ [] swap
witheach [ swap dip [ over + ] swap join ] nip ] is add ( n [ --> [ )
[ [] unrot
[ 2dup find 2dup swap found while 1+ split swap size dip rot join unrot again ] 2drop drop accumulate -1 swap add ] is findall ( x [ --> [ )
[ iff [ say "True" ]
else [ say "False" ] ] is echotruth ( b --> )
[ $ "BOXKDQCPNAGTRETGQDFS"
$ "JWHUVIANOBERFSLYPCZM" join ] constant is blocks ( --> $ )
[ -2 &
tuck pluck drop swap pluck drop ] is remove2 ( $ n --> $ )
forward is (abc)
[ dup [] = if bail
behead upper dip over swap findall witheach [ dip over remove2 over (abc) ] 2drop ] resolves (abc) ( $ $ --> )
[ blocks swap
2 backup (abc) bailed dup if [ dip 2drop ] echotruth ] is can_make_word ( $ --> )</lang>
Testing in the Quackery shell: Identical to iterative solution above.
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
Raku
(formerly 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({ my @c = .comb; rx/<@c>/ }).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
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
Red
<lang Red>Red [] test: func [ s][ p: copy "BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM" forever [
if 0 = length? s [ return 'true ] ;; if string cleared, all chars found/removed if tail? p [ return 'false ] ;; if at end of search block - not found rule: reduce [ first p '| second p] ;; construct parse rule from string either parse s [ to rule remove rule to end ] [ ;; remove found char from string remove/part p 2 ;;character found , remove block p: head p ;;start from remaining string at beginning aka head ] [ p: skip p 2 ] ;; else move to next block
] ] foreach word split {A bark book TrEAT COmMoN SQUAD conFUsE} space [
print reduce [ pad copy word 8 ":" test word] ]
</lang>
- Output:
A : true bark : true book : false TrEAT : true COmMoN : false SQUAD : true conFUsE : true
REXX
version 1
<lang rexx>/*REXX pgm finds if words can be spelt from a pool of toy blocks (each having 2 letters)*/ list= 'A bark bOOk treat common squaD conFuse' /*words can be: upper/lower/mixed 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 some 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 /*ARG uppercases the word to be spelt.*/
L= length(x); @.= 0 /*get length of the word to be spelt. */ do try=1 for L; z= blocks; upper z /*use a fresh copy of the "Z" blocks.*/ do n=1 for L; y= substr(x, n, 1) /*attempt another letter in the word. */ @.n= pos(y, z, 1 + @.n); if @.n==0 then leave /*not found? Try again*/ z= overlay(' ', z, @.n) /*mutate the toy block ───► a onesy. */ do q=1 for words(z); if length(word(z,q))==1 then z= delword(z, q, 1) end /*q*/ /* [↑] elide any existing onesy block.*/ if n==L then leave try /*was last letter used in the spelling?*/ end /*n*/ /* [↑] end of a toy block usage. */ end /*try*/ /* [↑] end of a "TRY" permute. */ say right( arg(1), 30) right( word( "can't can", (n==L) + 1), 6) 'be spelt.' return</lang>
- output when using the default inputs:
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. 'CONFUSE' 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 unbasic>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 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$(word$(blocks$,j,","),1) or w$ = right$(word$(blocks$,j,","),1) then hit(j) = 1 n = n + 1 exit for end if end if next j next k print wrd$;chr$(9); 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
SenseTalk
<lang sensetalk>function CanMakeWord word
put [ ("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") ] into blocks
repeat with each character letter of word put False into found repeat with each item block of blocks by reference if item 1 of block is letter ignoring case or item 2 of block is letter ignoring case delete block put True into found exit repeat end if end repeat if found is False return False end if end repeat return True
end CanMakeWord</lang>
<lang sensetalk>repeat with each item word in [ "A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"
]
put CanMakeWord(word) end repeat</lang>
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
Simula
<lang simula>COMMENT ABC PROBLEM; BEGIN
CLASS BLOCK(CH1, CH2); CHARACTER CH1, CH2; BEGIN BOOLEAN USED; END;
CLASS GAME(WORD, POSSIBLE); TEXT WORD; BOOLEAN POSSIBLE;;
BOOLEAN PROCEDURE CANMAKEWORD(WORD); TEXT WORD; BEGIN INTEGER I, NUMBLOCKS; BOOLEAN ALLPOSSIBLE, FOUND; NUMBLOCKS := UPPERBOUND(BLOCKS, 1); FOR I := 1 STEP 1 UNTIL NUMBLOCKS DO BLOCKS(I).USED := FALSE; ALLPOSSIBLE := TRUE;
WORD.SETPOS(1); WHILE ALLPOSSIBLE AND WORD.MORE DO BEGIN CHARACTER WORDCHAR; WORDCHAR := WORD.GETCHAR; FOUND := FALSE; FOR I := 1 STEP 1 UNTIL NUMBLOCKS DO BEGIN INSPECT BLOCKS(I) DO BEGIN IF (WORDCHAR = CH1 OR WORDCHAR = CH2) AND NOT USED THEN BEGIN USED := FOUND := TRUE; GOTO L; END; END; END; L: IF NOT FOUND THEN ALLPOSSIBLE := FALSE; END; CANMAKEWORD := ALLPOSSIBLE; END CANMAKEWORD;
REF(BLOCK) ARRAY BLOCKS(1:20); REF(GAME) ARRAY GAMES(1:7); TEXT WORD; BEGIN INTEGER I; I := I+1; BLOCKS(I) :- NEW BLOCK('B', 'O'); I := I+1; BLOCKS(I) :- NEW BLOCK('X', 'K'); I := I+1; BLOCKS(I) :- NEW BLOCK('D', 'Q'); I := I+1; BLOCKS(I) :- NEW BLOCK('C', 'P'); I := I+1; BLOCKS(I) :- NEW BLOCK('N', 'A'); I := I+1; BLOCKS(I) :- NEW BLOCK('G', 'T'); I := I+1; BLOCKS(I) :- NEW BLOCK('R', 'E'); I := I+1; BLOCKS(I) :- NEW BLOCK('T', 'G'); I := I+1; BLOCKS(I) :- NEW BLOCK('Q', 'D'); I := I+1; BLOCKS(I) :- NEW BLOCK('F', 'S'); I := I+1; BLOCKS(I) :- NEW BLOCK('J', 'W'); I := I+1; BLOCKS(I) :- NEW BLOCK('H', 'U'); I := I+1; BLOCKS(I) :- NEW BLOCK('V', 'I'); I := I+1; BLOCKS(I) :- NEW BLOCK('A', 'N'); I := I+1; BLOCKS(I) :- NEW BLOCK('O', 'B'); I := I+1; BLOCKS(I) :- NEW BLOCK('E', 'R'); I := I+1; BLOCKS(I) :- NEW BLOCK('F', 'S'); I := I+1; BLOCKS(I) :- NEW BLOCK('L', 'Y'); I := I+1; BLOCKS(I) :- NEW BLOCK('P', 'C'); I := I+1; BLOCKS(I) :- NEW BLOCK('Z', 'M'); END; BEGIN INTEGER N, I; BOOLEAN ANSWER; N := N+1; GAMES(N) :- NEW GAME("A", TRUE); N := N+1; GAMES(N) :- NEW GAME("BARK", TRUE); N := N+1; GAMES(N) :- NEW GAME("BOOK", FALSE); N := N+1; GAMES(N) :- NEW GAME("TREAT", TRUE); N := N+1; GAMES(N) :- NEW GAME("COMMON", FALSE); N := N+1; GAMES(N) :- NEW GAME("SQUAD", TRUE); N := N+1; GAMES(N) :- NEW GAME("CONFUSE", TRUE); FOR I := 1 STEP 1 UNTIL N DO BEGIN INSPECT GAMES(I) DO BEGIN OUTTEXT(WORD); OUTTEXT(" => "); ANSWER := CANMAKEWORD(WORD); OUTCHAR(IF ANSWER THEN 'T' ELSE 'F'); IF ANSWER EQV POSSIBLE THEN OUTTEXT(" OK") ELSE OUTTEXT(" ------------- WRONG!"); OUTIMAGE; END; END; END;
END.
</lang>
- Output:
A => T OK BARK => T OK BOOK => F OK TREAT => T OK COMMON => F OK SQUAD => T OK CONFUSE => T OK
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
SPAD
<lang SPAD> blocks:List Tuple Symbol:= _
[(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)]
findComb(l:List List NNI):List List NNI ==
#l=0 => [] #l=1 => [[s] for s in first l] r:List List NNI:=[] for y in findComb(rest l) repeat r:=concat(r,[concat(x,y) for x in first l]) return r
canMakeWord?(word,blocks) ==
word:=upperCase word bchr:=[map(char,map(string,s::List(Symbol))) for s in blocks] c:=[[j for j in 1..#blocks | member?(word.k,bchr.j)] for k in 1..#word] reduce(_or,[test(#removeDuplicates(l)=#word) for l in findComb(c)])
Example:=["a","bark","book","treat","common","squad","confuse"]
[canMakeWord?(s,blocks) for s in Example]
</lang>
Programming details:UserGuide
- Output:
[true,true,false,true,false,true,true] Type: List(Boolean)
There is optimization potential of course.
Standard ML
<lang OCaML> val 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")];
val words = ["A","BARK","BOOK","TREaT","COMMON","SQUAD","CONFUSE"]; open List;
local
val remove = fn x => fn B => (fn (a,b) => (tl a)@b ) (partition ( fn a=> x=a) B)
in fun cando ([] , Done, B ) = true
| cando (h::t, Done, []) = false | cando (h::t, Done, B ) = let val S = find (fn (a,b) => a=h orelse b=h) B in if isSome S then cando (t, (h,valOf S)::Done, remove (valOf S) B) else let val T = find ( fn(_,(a,b)) => a=h orelse b=h) Done val U = if isSome T then find (fn (a,b) => a = #1 (valOf T) orelse b = #1 (valOf T) ) B else NONE in if isSome T andalso isSome U then cando ( t, (#1 (valOf T),(valOf U))::(h,#2 (valOf T))::(remove (valOf T) Done), remove (valOf U) B) else false end end
end;
map (fn st => cando(map Char.toUpper (String.explode st),[],BLOCKS)) words;
val BLOCKS = [(#"U",#"S"), (#"T",#"Z"), (#"A",#"O"), (#"Q",#"A")]; val words = ["A","UTAH","AutO"]; map (fn st => cando(map Char.toUpper (String.explode st),[],BLOCKS)) words; </lang> Output
val it = [true, true, false, true, false, true, true]: bool list val it = [true, false, true]: bool list
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.
<lang Swift>import Swift
func canMake(word: String) -> Bool { var blocks = [ "BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM" ]
for letter in word.uppercased().characters { guard let index = blocks.index(where: { $0.characters.contains(letter) }) else { return false }
blocks.remove(at: index) }
return true }
let words = ["a", "bARK", "boOK", "TreAt", "CoMmon", "SquAd", "CONFUse"]
words.forEach { print($0, canMake(word: $0)) }</lang>
- Output:
A true BARK true BooK false TrEaT true comMON false sQuAd true Confuse true
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
Ultimate++
This is example is a slight modification of the C and C++ examples. To avoid warning "<bold>warning: ISO C++11 does not allow conversion from string literal to 'char *' [-Wwritable-strings]</bold> the strings added to char were individually prefixed with (char*). Swap is used instead of SWAP. Return 0 was not not needed.
<lang Cpp>
- include <Core/Core.h>
- include <stdio.h>
- include <ctype.h>
//C++
- include <iostream>
- include <vector>
- include <string>
- include <set>
- include <cctype>
//C++
typedef std::pair<char,char> item_t;
typedef std::vector<item_t> list_t;
//C
using namespace Upp;
int can_make_words(char **b, char *word) { int i, ret = 0, c = toupper(*word);
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]); // It needs to be Swap and not SWAP ret = can_make_words(b + 1, word + 1); Swap(b[i], b[0]); // It needs to be Swap instead of SWAP } return ret; }
//C++
bool can_create_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(); }
// U++
CONSOLE_APP_MAIN
{
// C
char* blocks[] =
{
(char*)"BO", (char*)"XK", (char*)"DQ", (char*)"CP",
(char*)"NA", (char*)"GT", (char*)"RE", (char*)"TG",
(char*)"QD", (char*)"FS", (char*)"JW", (char*)"HU",
(char*)"VI", (char*)"AN", (char*)"OB", (char*)"ER",
(char*)"FS", (char*)"LY", (char*)"PC", (char*)"ZM", 0
};
char *words[] = { (char*)"", (char*)"A", (char*)"BARK", (char*)"BOOK", (char*)"TREAT", (char*)"COMMON", (char*)"SQUAD", (char*)"Confuse", 0 };
char **w; for (w = words; *w; w++) printf("%s\t%d\n", *w, can_make_words(blocks, *w));
printf("\n");
// C++ 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> wordsb{"A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "Confuse"}; for (const std::string& w : wordsb) { std::cout << w << ": " << std::boolalpha << can_create_word(w, vals) << ".\n"; } std::cout << "\n";
const Vector<String>& cmdline = CommandLine(); for(int i = 0; i < cmdline.GetCount(); i++) { }
} </lang>
- Output:
1 A 1 BARK 1 BOOK 0 TREAT 1 COMMON 0 SQUAD 1 Confuse 1 A: true. BARK: true. BOOK: false. TREAT: true. COMMON: false. SQUAD: true. Confuse: true. <--- Finished in (0:00.53), exitcode: 0 --->
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
UTFool
String-based solution
<lang UTFool> ··· http://rosettacode.org/wiki/ABC_Problem ··· ■ ABC
§ static blocks⦂ StringBuffer " BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM" ▶ main • args⦂ String[] for each word in ["A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"]⦂ String System.out.println "⸨word⸩: ⸨canMakeWord word⸩"
▶ canMakeWord⦂ boolean • word⦂ String solution⦂ boolean: word.isEmpty° if no solution i⦂ int: blocks.indexOf word.substring 0, 1 🔁 until solution or i < 0 i: i ÷ 3 × 3 · block index block⦂ String: blocks.substring i, i + 3 blocks.delete i, i + 3 · remove block solution: canMakeWord word.substring 1 blocks.insert i, block · restore block i: blocks.indexOf (word.substring 0, 1), i + 3 return solution
</lang>
Collection-based solution
<lang UTFool> ··· http://rosettacode.org/wiki/ABC_Problem ··· import java.util.Arrays import java.util.Collections import java.util.List ■ ABC
§ static ▶ main • args⦂ String[] blocks⦂ List⟨String⟩: Arrays.asList "BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM" words⦂ List⟨String⟩: Arrays.asList "A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE" for each word in words System.out.println "⸨word⸩: ⸨canMakeWord word, blocks⸩"
▶ canMakeWord⦂ boolean • word⦂ String • blocks⦂ List⟨String⟩ if word.isEmpty° return true for each block #i in blocks⦂ String if 0 ≤ block.indexOf word.charAt 0 Collections.swap blocks, 0, i if canMakeWord (word.substring 1), blocks.subList 1, blocks.size° return true Collections.swap blocks, 0, i return false
</lang>
VBA
<lang vb> Option Explicit
Sub Main_ABC() Dim Arr, i As Long
Arr = Array("A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE") For i = 0 To 6 Debug.Print ">>> can_make_word " & Arr(i) & " => " & ABC(CStr(Arr(i))) Next i
End Sub
Function ABC(myWord As String) As Boolean Dim myColl As New Collection Dim NbLoop As Long, NbInit As Long Dim b As Byte, i As Byte Const BLOCKS As String = "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"
For b = 0 To 19 myColl.Add Split(BLOCKS, ";")(b), Split(BLOCKS, ";")(b) & b Next b NbInit = myColl.Count NbLoop = NbInit For b = 1 To Len(myWord) For i = 1 To NbLoop If i > NbLoop Then Exit For If InStr(myColl(i), Mid(myWord, b, 1)) <> 0 Then myColl.Remove (i) NbLoop = NbLoop - 1 Exit For End If Next Next b ABC = (NbInit = (myColl.Count + Len(myWord)))
End Function </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
Wren
<lang ecmascript>import "/fmt" for Fmt
var r // recursive r = Fn.new { |word, bl|
if (word == "") return true var c = word.bytes[0] | 32 for (i in 0...bl.count) { var b = bl[i] if (c == b.bytes[0] | 32 || c == b.bytes[1] | 32) { bl[i] = bl[0] bl[0] = b if (r.call(word[1..-1], bl[1..-1])) return true var t = bl[i] bl[i] = bl[0] bl[0] = t } } return false
}
var newSpeller = Fn.new { |blocks|
var bl = blocks.split(" ") return Fn.new { |word| r.call(word, bl) }
}
var sp = newSpeller.call("BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM") for (word in ["A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"]) {
System.print("%(Fmt.s(-7, word)) %(sp.call(word))")
}</lang>
- Output:
A true BARK true BOOK false TREAT true COMMON false SQUAD true CONFUSE true
XPL0
<lang XPL0>string 0;
char Side1, Side2; def Size = 20; char Avail(Size);
func CanMakeWord(Word); \returns 'true' if blocks can make Word char Word; int I, Let; [Let:= Word(0) & $5F; \get letter and make sure it's uppercase if Let = 0 then return true; \if 0 then end of word; return successful for I:= 0 to Size-1 do \scan for block that contains letter
if Avail(I) and (Side1(I) = Let or Side2(I) = Let) then [Avail(I):= false; if CanMakeWord(Word+1) then return true; ];
return false; ];
int I, J, Words; [Side1:= "BXDCNGRTQFJHVAOEFLPZ";
Side2:= "OKQPATEGDSWUINBRSYCM";
Words:= ["A", "bark", "Book", "Treat", "Common", "Squad", "conFuse"]; for J:= 0 to 6 do
[Text(0, "Can make ^""); Text(0, Words(J)); Text(0, "^": "); for I:= 0 to Size-1 do Avail(I):= true; Text(0, if CanMakeWord(Words(J)) then "True" else "False"); CrLf(0); ];
]</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
Yabasic
<lang Yabasic>letters$ = "BO,XK,DQ,CP,NA,GT,RE,TG,QD,FS,JW,HU,VI,AN,OB,ER,FS,LY,PC,ZM"
sub canMake(letters$, word$) local i, j, p, n, pairs$(1)
n = token(letters$, pairs$(), ",") word$ = upper$(word$)
for i = 1 to len(word$) for j = 1 to n p = instr(pairs$(j), mid$(word$, i, 1)) if p then pairs$(j) = "" break end if next j if not p return false next i return true end sub
print "a = ", canMake(letters$, "a") // 1 = true print "bark = ", canMake(letters$, "Bark") // 1 print "book = ", canMake(letters$, "BooK") // 0 = false print "treat = ", canMake(letters$, "TREAt") // 1 print "common = ", canMake(letters$, "common") // 0 print "squad = ", canMake(letters$, "squad") // 1 print "confuse = ", canMake(letters$, "confuse") // 1</lang>
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
zonnon
<lang zonnon> module Main; type Block = record l,r: char; used: boolean; end Block;
var blocks: array 20 of Block;
procedure Exists(c: char): boolean; var i: integer; r: boolean; begin r := false;i := 0; while ~r & (i < len(blocks)) do if ~(blocks[i].used) then r := (blocks[i].l = cap(c)) or (blocks[i].r = cap(c)); blocks[i].used := r; end; inc(i) end; return r end Exists;
procedure CanMakeWord(s: string); var i: integer; made: boolean; begin made := true; for i := 0 to len(s) - 1 do made := made & Exists(s[i]) end; writeln(s:20,"?",made); Clean() end CanMakeWord;
procedure Clean(); var i: integer; begin for i := 0 to len(blocks) - 1 do blocks[i].used := false end end Clean;
procedure InitBlock(i:integer;l,r:char); begin blocks[i].l := l;blocks[i].r := r; blocks[i].used := false; end InitBlock;
procedure Init; begin InitBlock(0,'B','O'); InitBlock(1,'X','K'); InitBlock(2,'D','Q'); InitBlock(3,'C','Q'); InitBlock(4,'N','A'); InitBlock(5,'G','T'); InitBlock(6,'R','E'); InitBlock(7,'T','G'); InitBlock(8,'Q','D'); InitBlock(9,'F','S'); InitBlock(10,'J','W'); InitBlock(11,'H','U'); InitBlock(12,'V','I'); InitBlock(13,'A','N'); InitBlock(14,'O','B'); InitBlock(15,'E','R'); InitBlock(16,'F','S'); InitBlock(17,'L','Y'); InitBlock(18,'P','C'); InitBlock(19,'Z','M') end Init;
begin Init(); CanMakeWord("A"); CanMakeWord("BARK"); CanMakeWord("BOOK"); CanMakeWord("TREAT"); CanMakeWord("COMMON"); CanMakeWord("confuse"); end Main. </lang>
- Output:
A ? true BARK ? true BOOK ? false TREAT ? true COMMON ? false confuse ? true
ZX Spectrum Basic
<lang zxbasic>10 LET b$="BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM" 20 READ p 30 FOR c=1 TO p 40 READ p$ 50 GO SUB 100 60 NEXT c 70 STOP 80 DATA 7,"A","BARK","BOOK","TREAT","COMMON","SQUAD","CONFUSE" 90 REM Can make? 100 LET u$=b$ 110 PRINT "Can make word ";p$;"? "; 120 FOR i=1 TO LEN p$ 130 FOR j=1 TO LEN u$ 140 IF p$(i)=u$(j) THEN GO SUB 200: GO TO 160 150 NEXT j 160 IF j>LEN u$ THEN PRINT "No": RETURN 170 NEXT i 180 PRINT "Yes": RETURN 190 REM Erase pair 200 IF j/2=INT (j/2) THEN LET u$(j-1 TO j)=" ": RETURN 210 LET u$(j TO j+1)=" ": RETURN</lang>
- Output:
Can make word A? Yes Can make word BARK? Yes Can make word BOOK? No Can make word TREAT? Yes Can make word COMMON? No Can make word SQUAD? Yes Can make word CONFYUSE? Yes
- Puzzles
- Games
- Programming Tasks
- Solutions by Programming Task
- 11l
- 360 Assembly
- 8080 Assembly
- 8086 Assembly
- 8th
- AArch64 Assembly
- ABAP
- Action!
- Acurity Architect
- Ada
- ALGOL 68
- ALGOL W
- Apex
- APL
- AppleScript
- ARM Assembly
- Arturo
- Astro
- AutoHotkey
- AWK
- BaCon
- BASIC
- Commodore BASIC
- Sinclair ZX81 BASIC
- Batch File
- BBC BASIC
- BCPL
- BQN
- Bracmat
- C
- C sharp
- C++
- Ceylon
- Clojure
- CLU
- CoffeeScript
- Comal
- Common Lisp
- Component Pascal
- Cowgol
- D
- Delphi
- Draco
- Dyalect
- EchoLisp
- Ela
- Elena
- Elixir
- Erlang
- ERRE
- Euphoria
- F Sharp
- Factor
- FBSL
- Forth
- Fortran
- FreeBASIC
- Gambas
- Go
- Groovy
- Harbour
- Haskell
- Icon
- Unicon
- J
- Java
- JavaScript
- Jq
- Jsish
- Julia
- Kotlin
- Liberty BASIC
- Logo
- Lua
- M2000 Interpreter
- Maple
- Mathematica
- Wolfram Language
- MATLAB
- Octave
- MAXScript
- Mercury
- MiniScript
- Nim
- Oberon-2
- Objeck
- OCaml
- Oforth
- OpenEdge/Progress
- Order
- PARI/GP
- Pascal
- Perl
- Phix
- PHP
- Picat
- PicoLisp
- PL/I
- PL/M
- PowerBASIC
- PowerShell
- Prolog
- PureBasic
- Python
- Q
- Quackery
- R
- Racket
- Raku
- RapidQ
- Red
- REXX
- Ring
- Ruby
- Run BASIC
- Rust
- Scala
- Scheme
- Seed7
- SenseTalk
- SequenceL
- Sidef
- Simula
- Smalltalk
- SPAD
- Standard ML
- Swift
- Tcl
- TUSCRIPT
- TXR
- Ultimate++
- UNIX Shell
- UTFool
- VBA
- Wren
- Wren-fmt
- XPL0
- Yabasic
- Zkl
- Zonnon
- ZX Spectrum Basic