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

Data commit

Browse source
This commit is contained in:
Ingy döt Net 2023-07-01 11:58:00 -04:00
parent 7387c8f97b
commit cb5bb5e222
199093 changed files with 3378972 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

5
Task/ABC-problem/00-META.yaml Normal file
View file

@ -0,0 +1,5 @@
---
category:
- Puzzles
- Games
from: http://rosettacode.org/wiki/ABC_problem

58
Task/ABC-problem/00-TASK.txt Normal file
View file

@ -0,0 +1,58 @@
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:
<syntaxhighlight 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</syntaxhighlight>
{{Template:Strings}}
<br><br>

16
Task/ABC-problem/11l/abc-problem.11l Normal file
View file

@ -0,0 +1,16 @@
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(‘, ’))

76
Task/ABC-problem/360-Assembly/abc-problem.360 Normal file
View file

@ -0,0 +1,76 @@
* 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

77
Task/ABC-problem/8080-Assembly/abc-problem.8080 Normal file
View file

@ -0,0 +1,77 @@
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$'

63
Task/ABC-problem/8086-Assembly/abc-problem.8086 Normal file
View file

@ -0,0 +1,63 @@
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$'

198
Task/ABC-problem/8th/abc-problem.8th Normal file
View file

@ -0,0 +1,198 @@
\ ========================================================================================
\ 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
;

187
Task/ABC-problem/AArch64-Assembly/abc-problem.aarch64 Normal file
View file

@ -0,0 +1,187 @@
/* 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"

72
Task/ABC-problem/ABAP/abc-problem.abap Normal file
View file

@ -0,0 +1,72 @@
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' ).

80
Task/ABC-problem/ALGOL-68/abc-problem.alg Normal file
View file

@ -0,0 +1,80 @@
# 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 )
)

81
Task/ABC-problem/ALGOL-W/abc-problem.alg Normal file
View file

@ -0,0 +1,81 @@
% 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.

1
Task/ABC-problem/APL/abc-problem.apl Normal file
View file

@ -0,0 +1 @@
abc←{{0=⍴⍵:1 ⋄ 0=⍴h←⊃⍵:0 ⋄ ∇(t←1↓⍵)~¨⊃h:1 ⋄ ∇(⊂1↓h),t}⍸¨↓⍵∘.∊⍺}

183
Task/ABC-problem/ARM-Assembly/abc-problem.arm Normal file
View file

@ -0,0 +1,183 @@
/* 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"

57
Task/ABC-problem/Action-/abc-problem.action Normal file
View file

@ -0,0 +1,57 @@
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

26
Task/ABC-problem/Acurity-Architect/abc-problem.acurity Normal file
View file

@ -0,0 +1,26 @@
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

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

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

45
Task/ABC-problem/Apex/abc-problem.apex Normal file
View file

@ -0,0 +1,45 @@
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'));

28
Task/ABC-problem/AppleScript/abc-problem-1.applescript Normal file
View file

@ -0,0 +1,28 @@
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

45
Task/ABC-problem/AppleScript/abc-problem-2.applescript Normal file
View file

@ -0,0 +1,45 @@
on canMakeWordWithBlocks(theString, theBlocks)
set stringLen to (count theString)
copy theBlocks to theBlocks
script o
on cmw(c, theBlocks)
set i to 1
repeat until (i > (count theBlocks))
if (character c of theString is in item i of theBlocks) then
if (c = stringLen) then return true
set item i of theBlocks to missing value
set theBlocks to text of theBlocks
if (cmw(c + 1, theBlocks)) then return true
end if
set i to i + 1
end repeat
return false
end cmw
end script
ignoring case -- Make the default case insensitivity explicit.
return ((theString = "") or (o's cmw(1, theBlocks)))
end ignoring
end canMakeWordWithBlocks
on join(lst, delim)
set astid to AppleScript's text item delimiters
set AppleScript's text item delimiters to delim
set txt to lst as text
set AppleScript's text item delimiters to astid
return txt
end join
on task()
set blocks to {"BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", ¬
"JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"}
set output to {}
repeat with testWord in {"a", "bark", "book", "treat", "common", "squad", "confuse"}
set end of output to "Can make “" & testWord & "”: " & ¬
canMakeWordWithBlocks(testWord's contents, blocks)
end repeat
return join(output, linefeed)
end task
task()

7
Task/ABC-problem/AppleScript/abc-problem-3.applescript Normal file
View file

@ -0,0 +1,7 @@
"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"

197
Task/ABC-problem/AppleScript/abc-problem-4.applescript Normal file
View file

@ -0,0 +1,197 @@
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

26
Task/ABC-problem/Arturo/abc-problem.arturo Normal file
View file

@ -0,0 +1,26 @@
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]

12
Task/ABC-problem/Astro/abc-problem.astro Normal file
View file

@ -0,0 +1,12 @@
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)})"

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

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

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

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

125
Task/ABC-problem/BASIC/abc-problem.basic Normal file
View file

@ -0,0 +1,125 @@
' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' 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

46
Task/ABC-problem/BASIC256/abc-problem.basic Normal file
View file

@ -0,0 +1,46 @@
arraybase 1
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((length(blocks$) /3) + 1)
dim blk$(b)
for i = 1 to length(makeWord$)
wrd$ = word$(makeWord$,i,",")
dim hit(b)
n = 0
if wrd$ = "" then exit for
for k = 1 to length(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 += 1
exit for
end if
end if
next j
next k
print wrd$; chr(9);
if n = length(wrd$) then print " True" else print " False"
next i
end
function word$(sr$, wn, delim$)
j = wn
if j = 0 then j += 1
res$ = "" : s$ = sr$ : d$ = delim$
if d$ = "" then d$ = " "
sd = length(d$) : sl = length(s$)
while true
n = instr(s$,d$) : j -= 1
if j = 0 then
if n = 0 then res$ = s$ else res$ = mid(s$,1,n-1)
return res$
end if
if n = 0 then return res$
if n = sl - sd then res$ = "" : return res$
sl2 = sl-n : s$ = mid(s$,n+1,sl2) : sl = sl2
end while
return res$
end function

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

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

37
Task/ABC-problem/BCPL/abc-problem.bcpl Normal file
View file

@ -0,0 +1,37 @@
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")
$)

16
Task/ABC-problem/BQN/abc-problem.bqn Normal file
View file

@ -0,0 +1,16 @@
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

24
Task/ABC-problem/BaCon/abc-problem.bacon Normal file
View file

@ -0,0 +1,24 @@
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

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

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

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

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

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

@ -0,0 +1 @@
g++-4.7 -Wall -std=c++0x abc.cpp

34
Task/ABC-problem/C++/abc-problem-2.cpp Normal file
View file

@ -0,0 +1,34 @@
#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";
}
}

30
Task/ABC-problem/C-sharp/abc-problem-1.cs Normal file
View file

@ -0,0 +1,30 @@
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;
}

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

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

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

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

44
Task/ABC-problem/CLU/abc-problem.clu Normal file
View file

@ -0,0 +1,44 @@
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

1
Task/ABC-problem/Ceylon/abc-problem-1.ceylon Normal file
View file

@ -0,0 +1 @@
module rosetta.abc "1.0.0" {}

74
Task/ABC-problem/Ceylon/abc-problem-2.ceylon Normal file
View file

@ -0,0 +1,74 @@
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;

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

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

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

@ -0,0 +1,18 @@
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)

19
Task/ABC-problem/Comal/abc-problem.comal Normal file
View file

@ -0,0 +1,19 @@
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"

25
Task/ABC-problem/Commodore-BASIC/abc-problem-1.basic Normal file
View file

@ -0,0 +1,25 @@
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

40
Task/ABC-problem/Commodore-BASIC/abc-problem-2.basic Normal file
View file

@ -0,0 +1,40 @@
100 REM RECURSIVE SOLUTION
110 MS=100:REM MAX STACK DEPTH
120 DIM BL$(MS):REM BLOCKS LEFT
130 DIM W$(MS):REM REMAINING LETTERS
140 DIM I(MS):REM LOOP CONTROL VARIABLE
150 DIM RV(MS):REM RETURN VALUE
160 SP=-1:REM STACK POINTER
170 READ BL$
180 PRINT "USING BLOCKS: "
190 FOR I=1 TO LEN(BL$) STEP 2
200 : PRINT"("MID$(BL$,I,2)")";
210 NEXT I
220 PRINT CHR$(13)
230 READ W$
240 IF W$="" THEN 320
250 PRINT W$;"->";
260 SP=SP+1:BL$(SP)=BL$:W$(SP)=W$
270 GOSUB 350
280 IF RV(SP) THEN PRINT "YES": GOTO 300
290 PRINT "NO"
300 SP=SP-1
310 GOTO 230
320 READ BL$
330 IF BL$ THEN PRINT:GOTO 180
340 END
350 IF LEN(W$(SP))=0 THEN RV(SP)=-1:RETURN
360 I(SP)=1
370 IF I(SP)>=LEN(BL$(SP)) THEN RV(SP)=0:RETURN
380 IF MID$(BL$(SP),I(SP),1) = LEFT$(W$(SP),1) THEN 410
390 IF MID$(BL$(SP),I(SP)+1,1) = LEFT$(W$(SP),1) THEN 410
400 GOTO 450
410 W$(SP+1)=MID$(W$(SP),2)
420 BL$(SP+1)=LEFT$(BL$(SP),I(SP)-1)+MID$(BL$(SP),I(SP)+2)
430 SP=SP+1:GOSUB 350:SP=SP-1
440 IF RV(SP+1) THEN RV(SP)=-1:RETURN
450 I(SP)=I(SP)+2:GOTO 370
460 DATA BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM
470 DATA A, BORK, BOOK, TREAT, COMMON, SQUAD, CONFUSE, ""
480 DATA ABABACAC,ABBA,""
490 DATA ""

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

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

84
Task/ABC-problem/Component-Pascal/abc-problem.pas Normal file
View file

@ -0,0 +1,84 @@
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.

44
Task/ABC-problem/Cowgol/abc-problem.cowgol Normal file
View file

@ -0,0 +1,44 @@
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;

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

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

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

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

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

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

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

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

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

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

53
Task/ABC-problem/Draco/abc-problem.draco Normal file
View file

@ -0,0 +1,53 @@
\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

26
Task/ABC-problem/Dyalect/abc-problem.dyalect Normal file
View file

@ -0,0 +1,26 @@
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 fin = ""
for c in strUp {
for j in blocks.Indices() {
if blocks[j].StartsWith(c) || blocks[j].EndsWith(c) {
fin += c
blocks[j] = ""
break
}
}
}
return fin == 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.")
}

28
Task/ABC-problem/ERRE/abc-problem.erre Normal file
View file

@ -0,0 +1,28 @@
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

16
Task/ABC-problem/EchoLisp/abc-problem.l Normal file
View file

@ -0,0 +1,16 @@
(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))))))

17
Task/ABC-problem/Ela/abc-problem.ela Normal file
View file

@ -0,0 +1,17 @@
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"]

45
Task/ABC-problem/Elena/abc-problem.elena Normal file
View file

@ -0,0 +1,45 @@
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));
}
}

16
Task/ABC-problem/Elixir/abc-problem.elixir Normal file
View file

@ -0,0 +1,16 @@
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)

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

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

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

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

30
Task/ABC-problem/F-Sharp/abc-problem-1.fs Normal file
View file

@ -0,0 +1,30 @@
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

40
Task/ABC-problem/F-Sharp/abc-problem-2.fs Normal file
View file

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

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

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

45
Task/ABC-problem/Factor/abc-problem.factor Normal file
View file

@ -0,0 +1,45 @@
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

30
Task/ABC-problem/Forth/abc-problem.fth Normal file
View file

@ -0,0 +1,30 @@
: 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 ;

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

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

277
Task/ABC-problem/Fortran/abc-problem-2.f Normal file
View file

@ -0,0 +1,277 @@
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

43
Task/ABC-problem/FreeBASIC/abc-problem.basic Normal file
View file

@ -0,0 +1,43 @@
' 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

41
Task/ABC-problem/FutureBasic/abc-problem.basic Normal file
View file

@ -0,0 +1,41 @@
include "NSLog.incl"
local fn CanBlocksSpell( w as CFStringRef ) as CFStringRef
NSUInteger i, j
CFStringRef cFinal = @"", result = @"NO"
CFMutableArrayRef blocks
blocks = fn MutableArrayWithArray( @[@"BO", @"XK", @"DQ", @"CP",¬
@"NA", @"GT", @"RE", @"TG", @"QD", @"FS", @"JW", @"HU", @"VI",¬
@"AN", @"OB", @"ER", @"FS", @"LY", @"PC", @"ZM"] )
CFStringRef cfStr = fn StringUppercaseString( w )
NSUInteger length = fn StringLength( cfStr )
NSUInteger count = fn ArrayCount( blocks )
for i = 0 to length - 1
for j = 0 to count - 1
CFStringRef charStr = mid( cfStr, i, 1 )
CFStringRef compareStr = fn ArrayObjectAtIndex( blocks, j )
CFStringRef testStr1 = mid( compareStr, 0, 1 )
CFStringRef testStr2 = mid( compareStr, 1, 1 )
if ( fn StringIsEqual( charStr, testStr1 ) == YES )
cFinal = fn StringByAppendingString( cFinal, testStr1 ) : MutableArrayReplaceObjectAtIndex( blocks, @" ", j ) : exit for
end if
if ( fn StringIsEqual( charStr, testStr2 ) == YES )
cFinal = fn StringByAppendingString( cFinal, testStr2 ) : MutableArrayReplaceObjectAtIndex( blocks, @" ", j ) : exit for
end if
next
next
if fn StringIsEqual( cFinal, cfStr ) == YES then result = @"YES"
end fn = result
NSLog( @"a: Can blocks spell? %@", fn CanBlocksSpell( @"a" ) )
NSLog( @"Bark: Can blocks spell? %@", fn CanBlocksSpell( @"Bark" ) )
NSLog( @"BOOK: Can blocks spell? %@", fn CanBlocksSpell( @"BOOK" ) )
NSLog( @"TrEaT: Can blocks spell? %@", fn CanBlocksSpell( @"TrEaT" ) )
NSLog( @"COMMON: Can blocks spell? %@", fn CanBlocksSpell( @"COMMON" ) )
NSLog( @"Squad: Can blocks spell? %@", fn CanBlocksSpell( @"Squad" ) )
NSLog( @"conFUse: Can blocks spell? %@", fn CanBlocksSpell( @"conFUse" ) )
HandleEvents

28
Task/ABC-problem/Gambas/abc-problem.gambas Normal file
View file

@ -0,0 +1,28 @@
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

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

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

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

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

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

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

32
Task/ABC-problem/Harbour/abc-problem.harbour Normal file
View file

@ -0,0 +1,32 @@
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

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

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

38
Task/ABC-problem/Haskell/abc-problem-2.hs Normal file
View file

@ -0,0 +1,38 @@
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"

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

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

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

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

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

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

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

@ -0,0 +1,4 @@
delElem=: {~<@<@<
uppc=:(-32*96&<*.123&>)&.(3&u:)
reduc=: ] delElem 1 i.~e."0 1
forms=: (1 - '' -: (reduc L:0/ :: (a:"_)@(<"0@],<@[))&uppc) L:0

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

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

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

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

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

@ -0,0 +1,14 @@
Blocks canform 0{::ExampleWords
1
word
A
need
2
relevant
NA
AN
candidates
ANA
ANN
AAA
AAN

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

@ -0,0 +1,36 @@
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;
}
}

37
Task/ABC-problem/JavaScript/abc-problem-1.js Normal file
View file

@ -0,0 +1,37 @@
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]));

48
Task/ABC-problem/JavaScript/abc-problem-2.js Normal file
View file

@ -0,0 +1,48 @@
(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');

7
Task/ABC-problem/JavaScript/abc-problem-3.js Normal file
View file

@ -0,0 +1,7 @@
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

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

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

67
Task/ABC-problem/JavaScript/abc-problem-5.js Normal file
View file

@ -0,0 +1,67 @@
(() => {
"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();
})();

29
Task/ABC-problem/Jq/abc-problem-1.jq Normal file
View file

@ -0,0 +1,29 @@
# 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;

5
Task/ABC-problem/Jq/abc-problem-2.jq Normal file
View file

@ -0,0 +1,5 @@
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

37
Task/ABC-problem/Jsish/abc-problem.jsish Normal file
View file

@ -0,0 +1,37 @@
#!/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!=
*/

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

@ -0,0 +1,19 @@
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

39
Task/ABC-problem/Kotlin/abc-problem.kotlin Normal file
View file

@ -0,0 +1,39 @@
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()

37
Task/ABC-problem/Lang/abc-problem.lang Normal file
View file

@ -0,0 +1,37 @@
fp.canMakeWord = ($word, $blocks) -> {
if(!$word) {
return 1
}
$word = fn.toLower($word)
$c $= $word[0]
$i = 0
while($i < @$blocks) {
$block $= fn.toLower($blocks[$i])
if($block[0] != $c && $block[1] != $c) {
$i += 1
con.continue
}
$blocksCopy $= ^$blocks
fn.listRemoveAt($blocksCopy, $i)
if(fp.canMakeWord(fn.substring($word, 1), $blocksCopy)) {
return 1
}
$i += 1
}
return 0
}
$blocks = fn.listOf(BO, XK, DQ, CP, NA, GT, RE, TG, QD, FS, JW, HU, VI, AN, OB, ER, FS, LY, PC, ZM)
$word
foreach($[word], [\e, A, BARK, BOOK, TREAT, COMMON, SQUAD, CONFUSE, Treat, cOmMoN]) {
fn.printf(%s: %s%n, $word, fp.canMakeWord($word, $blocks))
}

42
Task/ABC-problem/Liberty-BASIC/abc-problem-1.basic Normal file
View file

@ -0,0 +1,42 @@
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

133
Task/ABC-problem/Liberty-BASIC/abc-problem-2.basic Normal file
View file

@ -0,0 +1,133 @@
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

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