/* 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"


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]


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)})"


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
	}
}


#!/usr/bin/awk -f
# tested with mawk 1.3.3 on Raspberry Pi 3
#        also GNU awk 3.1.5, busybox 1.21.1 and 1.27.1 on AMD Sempron 2800+
#
function setblocks() {
# key to the algorithm is the representation of a block
# each block is represented by 4 characters in the string "blocks"
# for example, the "BO" block becomes "-BO-"
#
blocks="-BO--XK--DQ--CP--NA--GT--RE--TG--QD--FS--JW--HU--VI--AN--OB--ER--FS--LY--PC--ZM-"
true=1
false=0
}
function found(letter){
#
# the function "found" scans for the letter on the top of a block
# using the pattern "-B", for example, to find a "B",
# returning "true" (or 1) if found
# if not found on the top, look on the bottoms using the pattern "B-"
# again returning "true" if found
# if the letter is found on either top or bottom, the 4 character block is set to "----"
# so that block is unavailable
# finally, if no available copy of letter is found,
# the function returns "false" (0)
position= index(blocks,"-" letter)
if (position > 0)
   {
  blocks = substr(blocks,1,position-1) "----" substr(blocks,position+4)
  return true
   }
position = index(blocks,letter "-")
if (position > 0)
   {blocks = substr(blocks,1,position-3) "----" substr(blocks,position+2)
     return true
    }
return false
}
# awk's BEGIN statement allows for initialization before processing input;
# in this case, initializing the string "blocks"
#
BEGIN{
setblocks()
}
# in awk, the input record is contained in the string variable "$0"
# the main process checks each letter in turn to see if it is on a usable block,
# summing the values returned by "found"
# if the sum equals the number of input characters the word can be spelled with the blocks
# otherwise it is not possible
#
{
nchars=length($0)
possible=false
for (i=1;i<=nchars;i++){
     possible=possible + found(substr($0,i,1))
}
if (possible==nchars) print $0 " is possible"
   else print $0 " is not possible"
setblocks()
}


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


' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' ' '
' 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


@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


      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


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")
$)


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


(
  ( 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
);


#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;
}


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;
}


(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)))


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


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)


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"


(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))))))))


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.


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;


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));
}


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.


\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


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.")
}


(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))))))


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"]


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));
    }
}


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)


-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"]).


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


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


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 ([email protected]) 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


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 ] [email protected] <= ;

: enough-letters? ( str -- ? )
    [ blocks concat ] dip dup [ within ] dip
    [ histogram values ] [email protected] [ - ] 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


#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


: 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 [email protected] toupper    ( -- addr-input+1 c )
blockslist nip 0 do
  blocks @ i + dup [email protected] 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 ;


!-*- 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


' 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


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


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))
	}
}


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) }) }
    }
}


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


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"]


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


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=: *./@(+./)@[email protected](e."1~ ,)&toupper :: 0:


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;
    }
}


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]));


# 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;


#!/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!=
*/


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


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()


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


make "blocks [[B O] [X K] [D Q] [C P] [N A] [G T] [R E] [T G] [Q D] [F S]
              [J W] [H U] [V I] [A N] [O B] [E R] [F S] [L Y] [P C] [Z M]]

to can_make? :word [:avail :blocks]
  if empty? :word [output "true]
  local "letter make "letter first :word
  foreach :avail [
    local "i     make "i     #
    local "block make "block ?
    if member? :letter :block [
      if (can_make? bf :word filter [notequal? # :i] :avail) [output "true]
    ]
  ]
  output "false
end

foreach [A BARK BOOK TREAT COMMON SQUAD CONFUSE] [
  print sentence word ? ": can_make? ?
]

bye


blocks = {
	{"B","O"};	{"X","K"};	{"D","Q"};	{"C","P"};
	{"N","A"};	{"G","T"};	{"R","E"};	{"T","G"};
	{"Q","D"};	{"F","S"};	{"J","W"};	{"H","U"};
	{"V","I"};	{"A","N"};	{"O","B"};	{"E","R"};
	{"F","S"};	{"L","Y"};	{"P","C"};	{"Z","M"};
	};

function canUse(table, letter)
	for i,v in pairs(blocks) do
		if (v[1] == letter:upper() or v[2] == letter:upper())  and table[i] then
			table[i] = false;
			return true;
		end
	end
	return false;
end

function canMake(Word)
	local Taken = {};
	for i,v in pairs(blocks) do
		table.insert(Taken,true);
	end
	local found = true;
	for i = 1,#Word do
		if not canUse(Taken,Word:sub(i,i)) then
			found = false;
		end
	end
	print(found)
end


Module ABC {
      can_make_word("A")
      can_make_word("BaRk")
      can_make_word("BOOK")
      can_make_word("TREAT")
      can_make_word("CommoN")
      can_make_word("SQUAD")
      Gosub can_make_word("CONFUSE")  ' we can use Gosub before
      Sub can_make_word(c$)
            local b$=ucase$(c$)
            local i, a$="BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM", m
            for i=1 to len(b$)
                  m=Instr(a$,mid$(b$, i, 1))
                  If m=0 Then Exit for
                  Insert binary.or(m-1, 1),2 a$=""   ' delete 2 chars
            Next i
            Print c$, m<>0
      End Sub
}
ABC


canSpell := proc(w)
	local blocks, i, j, word, letterFound;
	blocks := Array([["B", "O"], ["X", "K"], ["D", "Q"], ["C", "P"], ["N", "A"], ["G", "T"], ["R", "E"], ["T", "G"],
                         ["Q", "D"], ["F", "S"], ["J", "W"], ["H", "U"], ["V", "I"], ["A", "N"], ["O", "B"], ["E", "R"],
                         ["F", "S"], ["L", "Y"], ["P", "C"], ["Z", "M"]]);
	word := StringTools[UpperCase](convert(w, string));
	for i to length(word) do
		letterFound := false;
		for j to numelems(blocks)/2 do
			if not letterFound and (substring(word, i) = blocks[j,1] or substring(word, i) = blocks[j,2]) then
				blocks[j,1] := undefined;
				blocks[j,2] := undefined;
				letterFound := true;
			end if;
		end do;
		if not letterFound then
			return false;
		end if;
	end do;
	return true;
end proc:

seq(printf("%a: %a\n", i, canSpell(i)), i in [a, Bark, bOok, treat, COMMON, squad, confuse]);


blocks=Partition[Characters[ToLowerCase["BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"]],2];
ClearAll[DoStep,ABCBlockQ]
DoStep[chars_List,blcks_List,chosen_List]:=Module[{opts},
 If[chars=!={},
  opts=Select[blcks,MemberQ[#,First[chars]]&];
  {Rest[chars],DeleteCases[blcks,#,1,1],Append[chosen,#]}&/@opts
 ,
  {{chars,blcks,chosen}}
 ]
]
DoStep[opts_List]:=Flatten[[email protected]@@opts,1]
ABCBlockQ[str_String]:=(FixedPoint[DoStep,{{Characters[ToLowerCase[str]],blocks,{}}}]=!={})


function testABC
    combos = ['BO' ; 'XK' ; 'DQ' ; 'CP' ; 'NA' ; 'GT' ; 'RE' ; 'TG' ; 'QD' ; ...
        'FS' ; 'JW' ; 'HU' ; 'VI' ; 'AN' ; 'OB' ; 'ER' ; 'FS' ; 'LY' ; ...
        'PC' ; 'ZM'];
    words = {'A' 'BARK' 'BOOK' 'TREAT' 'COMMON' 'SQUAD' 'CONFUSE'};
    for k = 1:length(words)
        possible = canMakeWord(words{k}, combos);
        fprintf('Can%s make word %s.\n', char(~possible.*'NOT'), words{k})
    end
end

function isPossible = canMakeWord(word, combos)
    word = lower(word);
    combos = lower(combos);
    isPossible = true;
    k = 1;
    while isPossible && k <= length(word)
        [r, c] = find(combos == word(k), 1);
        if ~isempty(r)
            combos(r, :) = '';
        else
            isPossible = false;
        end
        k = k+1;
    end
end


-- This is the blocks array
global GlobalBlocks = #("BO","XK","DQ","CP","NA", \
			"GT","RE","TG","QD","FS", \
			"JW","HU","VI","AN","OB", \
			"ER","FS","LY","PC","ZM")

-- This function returns true if "_str" is part of "_word", false otherwise
fn occurs _str _word =
(
	if _str != undefined and _word != undefined then
	(
	matchpattern _word pattern:("*"+_str+"*")
	) else return false
)

-- This is the main function
fn isWordPossible word blocks: = -- blocks is a keyword argument
(
	word = toupper word -- convert the string to upper case, to make it case insensitive
	if blocks == unsupplied do blocks = GlobalBlocks
	-- if blocks (keyword argument) is unsupplied, use the global blocks array (this is for recursion)

	blocks = deepcopy blocks

	local pos = 1 -- start at the beginning of the word
	local solvedLetters = #() -- this array stores the indices of solved letters

	while pos <= word.count do -- loop through every character in the word
	(
		local possibleBlocks = #() -- this array stores the blocks which can be used to make that letter
		for b = 1 to Blocks.count do -- this loop finds all the possible blocks that can be used to make that letter
		(
			if occurs word[pos] blocks[b] do
			(
				appendifunique possibleBlocks b
			)
		)
		if possibleBlocks.count > 0 then -- if it found any blocks
		(
			if possibleBlocks.count == 1 then -- if it found one block, then continue
			(
				appendifunique solvedLetters pos
				deleteitem blocks possibleblocks[1]
				pos += 1
			)
			else -- if it found more than one
			(
				for b = 1 to possibleBlocks.count do -- loop through every possible block
				(
					local possibleBlock = blocks[possibleBlocks[b]]
					local blockFirstLetter = possibleBlock[1]
					local blockSecondLetter = possibleBlock[2]
					local matchingLetter = if blockFirstLetter == word[pos] then 1 else 2
					-- ^ this is the index of the matching letter on the block

					local notMatchingIndex = if matchingLetter == 1 then 2 else 1
					local notMatchingLetter = possibleBlock[notMatchingIndex]
					-- ^ this is the other letter on the block

					if occurs notMatchingLetter (substring word (pos+1) -1) then
					( -- if the other letter occurs in the rest of the word
						local removedBlocks = deepcopy blocks -- copy the current blocks array
						deleteitem removedBlocks possibleBlocks[b] -- remove the item from the copied array

						-- recursively check if the word is possible if that block is taken away from the array:
						if (isWordPossible (substring word (pos+1) -1) blocks:removedBlocks) then
						( -- if it is, then remove the block and move to next character
							appendifunique solvedLetters pos
							deleteitem blocks possibleblocks[1]
							pos += 1
							exit
						)
						else
						( -- if it isn't and it looped through every possible block, then the word is not possible
							if b == possibleBlocks.count do return false
						)
					)
					else
					( -- if the other letter on this block doesn't occur in the rest of the word, then the letter is solved, continue
							appendifunique solvedLetters pos
							deleteitem blocks possibleblocks[b]
							pos += 1
							exit
					)
				)
			)
		) else return false -- if it didn't find any blocks, then return false
	)

	makeuniquearray solvedLetters -- make sure there are no duplicates in the solved array
	if solvedLetters.count != word.count then return false -- if number of solved letters is not equal to word length
		else
			( -- this checks if all the solved letters are the same as the word
				check = ""
				for bit in solvedLetters do append check word[bit]
				if check == word then return true else return false
			)
)


:- module abc.
:- interface.
:- import_module io.
:- pred main(io::di, io::uo) is det.
:- implementation.
:- import_module list, string, char.

:- type block == {char, char}.

:- pred take(char, list(block), list(block)).
:- mode take(in, in, out) is nondet.
take(C, !Blocks) :-
    list.delete(!.Blocks, {A, B}, !:Blocks),
    ( A = C ; B = C ).

:- pred can_make_word(list(char)::in, list(block)::in) is semidet.
can_make_word([], _).
can_make_word([C|Cs], !.Blocks) :-
    take(C, !Blocks),
    can_make_word(Cs, !.Blocks).

main(!IO) :-
    Blocks = [
        {'B', 'O'}, {'X', 'K'}, {'D', 'Q'}, {'C', 'P'}, {'N', 'A'},
        {'G', 'T'}, {'R', 'E'}, {'T', 'G'}, {'Q', 'D'}, {'F', 'S'},
        {'J', 'W'}, {'H', 'U'}, {'V', 'I'}, {'A', 'N'}, {'O', 'B'},
        {'E', 'R'}, {'F', 'S'}, {'L', 'Y'}, {'P', 'C'}, {'Z', 'M'}
    ],
    Words = ["A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"],
    foldl((pred(W::in, !.IO::di, !:IO::uo) is det :-
            P = can_make_word(to_char_list(W), Blocks),
            io.format("can_make_word(""%s"") :- %s.\n",
                [s(W), s(if P then "true" else "fail")], !IO)),
        Words, !IO).


allBlocks = ["BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"]

swap = function(list, index1, index2)
    tmp = list[index1]
    list[index1] = list[index2]
    list[index2] = tmp
end function

canMakeWord = function(str, blocks)
    if str == "" then return true
    c = str[0].upper
    for i in range(0, blocks.len - 1)
        bl = blocks[i]
        if c != bl[0] and c != bl[1] then continue
        swap blocks, 0, i
        if canMakeWord(str[1:], blocks[1:]) then return true
        swap blocks, 0, i
    end for
    return false
end function

for val in ["", "A", "BARK", "book", "Treat", "COMMON", "sQuAD", "CONFUSE"]
    out = """"""
    if val.len != 0 then out = val
    print out + ": " + canMakeWord(val, allBlocks)
end for


import std / strutils

func canMakeWord(blocks: seq[string]; word: string): bool =
    if blocks.len < word.len: return false
    if word.len == 0: return true

    let ch = word[0].toUpperAscii
    for i, pair in blocks:
        if ch in pair and
           (blocks[0..<i] & blocks[i+1..^1]).canMakeWord(word[1..^1]):
            return true

proc main =
    for (blocks, words) in [
        ("BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM".splitWhitespace,
         @["A", "bArK", "BOOK", "treat", "common", "sQuAd", "CONFUSE"]),
        ("AB AB AC AC".splitWhitespace, @["ABBa"]),
        ("US TZ AO QA".splitWhitespace, @["Auto"])
    ]:
        echo "Using the blocks ", blocks.join(" ")
        for word in words:
            echo " can we make the word '$#'? $#" % [
                word, if blocks.canMakeWord(word): "yes" else: "no"]
        echo()

when isMainModule: main()


MODULE ABCBlocks;
IMPORT
  Object,
  Out;

VAR
  blocks: ARRAY 20 OF STRING;

    PROCEDURE CanMakeWord(w: STRING): BOOLEAN;
    VAR
      used: ARRAY 20 OF LONGINT;
      wChars: Object.CharsLatin1;
      i,j: LONGINT;

      PROCEDURE IsUsed(i: LONGINT): BOOLEAN;
      VAR
        b: LONGINT;
      BEGIN
        b := 0;
        WHILE (b < LEN(used) - 1) & (used[b] # -1) DO
          IF used[b] = i THEN RETURN TRUE END;
          INC(b)
        END;
        RETURN FALSE
      END IsUsed;

      PROCEDURE GetBlockFor(blocks: ARRAY OF STRING; c: CHAR): LONGINT;
      VAR
        i: LONGINT;
      BEGIN
        i := 0;
        WHILE (i < LEN(blocks)) DO
          IF (blocks[i].IndexOf(c,0) >= 0) & (~IsUsed(i)) THEN RETURN i END;
          INC(i)
        END;

        RETURN -1;
      END GetBlockFor;

    BEGIN
      FOR i := 0 TO LEN(used) - 1 DO used[i] := -1 END;
      wChars := w(Object.String8).CharsLatin1();

      i := 0;
      WHILE (i < LEN(wChars^) - 1) DO
        j := GetBlockFor(blocks,CAP(wChars[i]));
        IF j < 0 THEN RETURN FALSE END;
        used[i] := j;
        INC(i)
      END;
      RETURN TRUE
    END CanMakeWord;

BEGIN
  blocks[0] := "BO";
  blocks[1] := "XK";
  blocks[2] := "DQ";
  blocks[3] := "CP";
  blocks[4] := "NA";
  blocks[5] := "GT";
  blocks[6] := "RE";
  blocks[7] := "TG";
  blocks[8] := "QD";
  blocks[9] := "FS";
  blocks[10] := "JW";
  blocks[11] := "HU";
  blocks[12] := "VI";
  blocks[13] := "AN";
  blocks[14] := "OB";
  blocks[15] := "ER";
  blocks[16] := "FS";
  blocks[17] := "LY";
  blocks[18] := "PC";
  blocks[19] := "ZM";

  Out.String("A: ");Out.Bool(CanMakeWord("A"));Out.Ln;
  Out.String("BARK: ");Out.Bool(CanMakeWord("BARK"));Out.Ln;
  Out.String("BOOK: ");Out.Bool(CanMakeWord("BOOK"));Out.Ln;
  Out.String("TREAT: ");Out.Bool(CanMakeWord("TREAT"));Out.Ln;
  Out.String("COMMON: ");Out.Bool(CanMakeWord("COMMON"));Out.Ln;
  Out.String("SQAD: ");Out.Bool(CanMakeWord("SQUAD"));Out.Ln;
  Out.String("confuse: ");Out.Bool(CanMakeWord("confuse"));Out.Ln;
END ABCBlocks.


class Abc {
  function : Main(args : String[]) ~ Nil {
    blocks := ["BO", "XK", "DQ", "CP", "NA",
      "GT", "RE", "TG", "QD", "FS",
      "JW", "HU", "VI", "AN", "OB",
      "ER", "FS", "LY", "PC", "ZM"];

    IO.Console->Print("\"\": ")->PrintLine(CanMakeWord("", blocks));
    IO.Console->Print("A: ")->PrintLine(CanMakeWord("A", blocks));
    IO.Console->Print("BARK: ")->PrintLine(CanMakeWord("BARK", blocks));
    IO.Console->Print("book: ")->PrintLine(CanMakeWord("book", blocks));
    IO.Console->Print("treat: ")->PrintLine(CanMakeWord("treat", blocks));
    IO.Console->Print("COMMON: ")->PrintLine(CanMakeWord("COMMON", blocks));
    IO.Console->Print("SQuAd: ")->PrintLine(CanMakeWord("SQuAd", blocks));
    IO.Console->Print("CONFUSE: ")->PrintLine(CanMakeWord("CONFUSE", blocks));
  }

  function : CanMakeWord(word : String, blocks : String[]) ~ Bool {
    if(word->Size() = 0) {
          return true;
    };

      c := word->Get(0)->ToUpper();
      for(i := 0; i < blocks->Size(); i++;) {
      b := blocks[i];
      if(<>(b->Get(0)->ToUpper() <> c & b->Get(1)->ToUpper() <> c)) {
        Swap(0, i, blocks);
        new_word := word->SubString(1, word->Size() - 1);
        new_blocks := String->New[blocks->Size() - 1];
        Runtime->Copy(new_blocks, 0, blocks, 1, blocks->Size() - 1);
        if(CanMakeWord(new_word, new_blocks)) {
          return true;
        };
        Swap(0, i, blocks);
      };
    };

    return false;
  }

  function : native : Swap(i : Int, j : Int, arr : String[]) ~ Nil {
    tmp := arr[i];
    arr[i] := arr[j];
    arr[j] := tmp;
  }
}


let blocks = [
  ('B', 'O');  ('X', 'K');  ('D', 'Q');  ('C', 'P');
  ('N', 'A');  ('G', 'T');  ('R', 'E');  ('T', 'G');
  ('Q', 'D');  ('F', 'S');  ('J', 'W');  ('H', 'U');
  ('V', 'I');  ('A', 'N');  ('O', 'B');  ('E', 'R');
  ('F', 'S');  ('L', 'Y');  ('P', 'C');  ('Z', 'M');
]

let find_letter blocks c =
  let found, remaining =
    List.partition (fun (c1, c2) -> c1 = c || c2 = c) blocks
  in
  match found with
  | _ :: res -> Some (res @ remaining)
  | _ -> None

let can_make_word w =
  let n = String.length w in
  let rec aux i _blocks =
    if i >= n then true else
      match find_letter _blocks w.[i] with
      | None -> false
      | Some rem_blocks ->
          aux (succ i) rem_blocks
  in
  aux 0 blocks

let test label f (word, should) =
  Printf.printf "- %s %S = %B  (should: %B)\n" label word (f word) should

let () =
  List.iter (test "can make word" can_make_word) [
    "A", true;
    "BARK", true;
    "BOOK", false;
    "TREAT", true;
    "COMMON", false;
    "SQUAD", true;
    "CONFUSE", true;
  ]


import: mapping

["BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS","JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"]
const: ABCBlocks

: canMakeWord(w, blocks)
| i |
   w empty? ifTrue: [ true return ]
   blocks size loop: i [
      w first >upper  blocks at(i) include? ifFalse: [ continue ]
      canMakeWord( w right( w size 1- ), blocks del(i, i) ) ifTrue: [ true return ]
      ]
   false
;


FUNCTION canMakeWord RETURNS LOGICAL (INPUT pWord AS CHARACTER) FORWARD.

/* List of blocks */
DEFINE TEMP-TABLE ttBlocks NO-UNDO
    FIELD ttFaces AS CHARACTER FORMAT "x(1)" EXTENT 2
    FIELD ttUsed AS LOGICAL.

/* Fill in list of blocks */
RUN AddBlock("BO").
RUN AddBlock("XK").
RUN AddBlock("DQ").
RUN AddBlock("CP").
RUN AddBlock("NA").
RUN AddBlock("GT").
RUN AddBlock("Re").
RUN AddBlock("TG").
RUN AddBlock("QD").
RUN AddBlock("FS").
RUN AddBlock("JW").
RUN AddBlock("HU").
RUN AddBlock("VI").
RUN AddBlock("AN").
RUN AddBlock("OB").
RUN AddBlock("ER").
RUN AddBlock("FS").
RUN AddBlock("LY").
RUN AddBlock("PC").
RUN AddBlock("ZM").

DEFINE VARIABLE chWords AS CHARACTER EXTENT 7 NO-UNDO.
ASSIGN  chWords[1] = "A"
        chWords[2] = "BARK"
        chWords[3] = "BOOK"
        chWords[4] = "TREAT"
        chWords[5] = "COMMON"
        chWords[6] = "SQUAD"
        chWords[7] = "CONFUSE".

DEFINE FRAME frmResult
    WITH NO-LABELS 7 DOWN USE-TEXT.

DEFINE VARIABLE i AS INTEGER NO-UNDO.
DO i = 1 TO 7:
    DISPLAY chWords[i] + " = " + STRING(canMakeWord(chWords[i])) FORMAT "x(25)" WITH FRAME frmResult.
    DOWN WITH FRAME frmResult.
END.

PROCEDURE AddBlock:
    DEFINE INPUT PARAMETER i-chBlockvalue AS CHARACTER NO-UNDO.

    IF (LENGTH(i-chBlockValue) <> 2)
        THEN RETURN ERROR.

    CREATE ttBlocks.
    ASSIGN  ttBlocks.ttFaces[1] = SUBSTRING(i-chBlockValue, 1, 1)
            ttBlocks.ttFaces[2] = SUBSTRING(i-chBlockValue, 2, 1).
END PROCEDURE.

FUNCTION blockInList RETURNS LOGICAL (pChar AS CHARACTER):
    /* Find first unused block in list */
    FIND FIRST ttBlocks WHERE (ttBlocks.ttFaces[1] = pChar
                               OR ttBlocks.ttFaces[2] = pChar)
                          AND NOT ttBlocks.ttUsed NO-ERROR.
    IF (AVAILABLE ttBlocks) THEN DO:
        /* found it! set to used and return true */
        ASSIGN ttBlocks.ttUsed = TRUE.
        RETURN TRUE.
    END.
    ELSE RETURN FALSE.
END FUNCTION.

FUNCTION canMakeWord RETURNS LOGICAL (INPUT pWord AS CHARACTER):
    DEFINE VARIABLE i AS INTEGER NO-UNDO.
    DEFINE VARIABLE chChar AS CHARACTER NO-UNDO.

    /* Word has to be valid */
    IF (LENGTH(pWord) = 0)
        THEN RETURN FALSE.

    DO i = 1 TO LENGTH(pWord):
        /* get the char */
        chChar = SUBSTRING(pWord, i, 1).

        /* Check to see if this is a letter? */
        IF ((ASC(chChar) < 65) OR (ASC(chChar) > 90) AND
            (ASC(chChar) < 97) OR (ASC(chChar) > 122))
            THEN RETURN FALSE.

        /* Is block is list (and unused) */
        IF NOT blockInList(chChar)
            THEN RETURN FALSE.
    END.

    /* Reset all blocks */
    FOR EACH ttBlocks:
        ASSIGN ttUsed = FALSE.
    END.
    RETURN TRUE.
END FUNCTION.


#include <order/interpreter.h>
#include <order/lib.h>

// Because of technical limitations, characters within a "string" must be separated by white spaces.
// For the sake of simplicity, only upper-case characters are supported here.

// A few lines of boiler-plate oriented programming are needed to enable character parsing and comparison.
#define ORDER_PP_TOKEN_A (A)
#define ORDER_PP_TOKEN_B (B)
#define ORDER_PP_TOKEN_C (C)
#define ORDER_PP_TOKEN_D (D)
#define ORDER_PP_TOKEN_E (E)
#define ORDER_PP_TOKEN_F (F)
#define ORDER_PP_TOKEN_G (G)
#define ORDER_PP_TOKEN_H (H)
#define ORDER_PP_TOKEN_I (I)
#define ORDER_PP_TOKEN_J (J)
#define ORDER_PP_TOKEN_K (K)
#define ORDER_PP_TOKEN_L (L)
#define ORDER_PP_TOKEN_M (M)
#define ORDER_PP_TOKEN_N (N)
#define ORDER_PP_TOKEN_O (O)
#define ORDER_PP_TOKEN_P (P)
#define ORDER_PP_TOKEN_Q (Q)
#define ORDER_PP_TOKEN_R (R)
#define ORDER_PP_TOKEN_S (S)
#define ORDER_PP_TOKEN_T (T)
#define ORDER_PP_TOKEN_U (U)
#define ORDER_PP_TOKEN_V (V)
#define ORDER_PP_TOKEN_W (W)
#define ORDER_PP_TOKEN_X (X)
#define ORDER_PP_TOKEN_Y (Y)
#define ORDER_PP_TOKEN_Z (Z)

#define ORDER_PP_SYM_A(...) __VA_ARGS__
#define ORDER_PP_SYM_B(...) __VA_ARGS__
#define ORDER_PP_SYM_C(...) __VA_ARGS__
#define ORDER_PP_SYM_D(...) __VA_ARGS__
#define ORDER_PP_SYM_E(...) __VA_ARGS__
#define ORDER_PP_SYM_F(...) __VA_ARGS__
#define ORDER_PP_SYM_G(...) __VA_ARGS__
#define ORDER_PP_SYM_H(...) __VA_ARGS__
#define ORDER_PP_SYM_I(...) __VA_ARGS__
#define ORDER_PP_SYM_J(...) __VA_ARGS__
#define ORDER_PP_SYM_K(...) __VA_ARGS__
#define ORDER_PP_SYM_L(...) __VA_ARGS__
#define ORDER_PP_SYM_M(...) __VA_ARGS__
#define ORDER_PP_SYM_N(...) __VA_ARGS__
#define ORDER_PP_SYM_O(...) __VA_ARGS__
#define ORDER_PP_SYM_P(...) __VA_ARGS__
#define ORDER_PP_SYM_Q(...) __VA_ARGS__
#define ORDER_PP_SYM_R(...) __VA_ARGS__
#define ORDER_PP_SYM_S(...) __VA_ARGS__
#define ORDER_PP_SYM_T(...) __VA_ARGS__
#define ORDER_PP_SYM_U(...) __VA_ARGS__
#define ORDER_PP_SYM_V(...) __VA_ARGS__
#define ORDER_PP_SYM_W(...) __VA_ARGS__
#define ORDER_PP_SYM_X(...) __VA_ARGS__
#define ORDER_PP_SYM_Y(...) __VA_ARGS__
#define ORDER_PP_SYM_Z(...) __VA_ARGS__

/// 8blocks_lexer (string) : Seq String -> Seq (Seq Sym)
#define ORDER_PP_DEF_8blocks_lexer ORDER_PP_FN \
(8fn (8S \
     ,8seq_map (8tokens_to_seq \
               ,8S \
               ) \
     ) \
)

// Keying the blocks makes filtering them way more efficient than by comparing their letters.
/// 8seq_keyed (sequence) : Seq a -> Seq (Pair Num a)
#define ORDER_PP_DEF_8seq_keyed ORDER_PP_FN \
(8fn (8S \
     ,8stream_to_seq (8stream_pair_with (8pair \
                                        ,8stream_of_naturals \
                                        ,8seq_to_stream (8S) \
                                        ) \
                     ) \
     ) \
)

/// 8abc_internal (blocks, word) : Seq (Pair Num (Seq Token)) -> Seq Token -> Bool
#define ORDER_PP_DEF_8abc_internal ORDER_PP_FN \
(8fn (8B, 8W \
     ,8if (8seq_is_nil (8W) \
          ,8true \
          ,8lets ((8C, 8seq_head (8W)) \
                  (8S, 8seq_filter (8chain (8seq_exists (8same (8C)) \
                                           ,8tuple_at_1 \
                                           ) \
                                   ,8B \
                                   ) \
                  ) \
                  (8T, 8seq_map (8chain (8flip (8seq_filter \
                                               ,8B \
                                               ) \
                                        ,8bin_pr (8not_eq \
                                                 ,8tuple_at_0 \
                                                 ) \
                                        ) \
                                ,8S \
                                ) \
                  ) \
                 ,8seq_exists (8flip (8abc_internal \
                                     ,8seq_tail (8W) \
                                     ) \
                              ,8T \
                              ) \
                 ) \
          ) \
     ) \
)

/// 8abc (blocks, word) : Seq (String) -> String -> Bool
#define ORDER_PP_DEF_8abc ORDER_PP_FN \
(8fn (8B, 8W \
     ,8abc_internal (8seq_keyed (8blocks_lexer (8B)) \
                    ,8tokens_to_seq (8W) \
                    ) \
     ) \
)

#define ORDER_PP_DEF_8blocks ORDER_PP_CONST ( \
    (B O) \
    (X K) \
    (D Q) \
    (C P) \
    (N A) \
    (G T) \
    (R E) \
    (T G) \
    (Q D) \
    (F S) \
    (J W) \
    (H U) \
    (V I) \
    (A N) \
    (O B) \
    (E R) \
    (F S) \
    (L Y) \
    (P C) \
    (Z M) \
)

ORDER_PP
(8seq_map (8step (8pair (8identity
                        ,8abc (8blocks)
                        )
                 )
          ,8quote ((A)
                   (B A R K)
                   (B O O K)
                   (T R E A T)
                   (C O M M O N)
                   (S Q U A D)
                   (C O N F U S E)
                  )
          )
)


BLOCKS = "BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM";
WORDS  = ["A","Bark","BOOK","Treat","COMMON","SQUAD","conFUSE"];

can_make_word(w) = check(Vecsmall(BLOCKS), Vecsmall(w))

check(B,W,l=1,n=1) =
{
  if (l > #W, return(1), n > #B, return(0));

  forstep (i = 1, #B-2, 2,
    if (B[i] != bitand(W[l],223) && B[i+1] != bitand(W[l],223), next());
    B[i] = B[i+1] = 0;
    if (check(B, W, l+1, n+2), return(1))
  );
  0
}

for (i = 1, #WORDS, printf("%s\t%d\n", WORDS[i], can_make_word(WORDS[i])));


#!/usr/bin/instantfpc
//program ABCProblem;

{$mode objfpc}{$H+}

uses SysUtils, Classes;

const
  // every couple of chars is a block
  // remove one by replacing its 2 chars by 2 spaces
  Blocks =  'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM';
  BlockSize = 3;

function can_make_word(Str: String): boolean;
var
  wkBlocks: string = Blocks;
  c: Char;
  iPos : Integer;
begin
  // all chars to uppercase
  Str := UpperCase(Str);
  Result := Str <> '';
  if Result then
  begin
    for c in Str do
    begin
      iPos := Pos(c, wkBlocks);
      if (iPos > 0) then
      begin
        // Char found
        wkBlocks[iPos] := ' ';
        // Remove the other face
        if (iPos mod BlockSize = 1) then
          wkBlocks[iPos + 1] := ' '
        else
          wkBlocks[iPos - 1] := ' ';
      end
      else
      begin
        //  missed
        Result := False;
        break;
      end;
    end;
  end;
  // Debug...
  //WriteLn(Blocks);
  //WriteLn(wkBlocks);
End;

procedure TestABCProblem(Str: String);
const
  boolStr : array[boolean] of String = ('False', 'True');
begin
  WriteLn(Format('>>> can_make_word("%s")%s%s', [Str, LineEnding, boolStr[can_make_word(Str)]]));
End;

begin
  TestABCProblem('A');
  TestABCProblem('BARK');
  TestABCProblem('BOOK');
  TestABCProblem('TREAT');
  TestABCProblem('COMMON');
  TestABCProblem('SQUAD');
  TestABCProblem('CONFUSE');
END.


#!/usr/bin/perl
use warnings;
use strict;

sub can_make_word {
    my ($word, @blocks) = @_;
    $_ = uc join q(), sort split // for @blocks;
    my %blocks;
    $blocks{$_}++ for @blocks;
    return _can_make_word(uc $word, %blocks)
}

sub _can_make_word {
    my ($word, %blocks) = @_;
    my $char = substr $word, 0, 1, q();

    my @candidates = grep 0 <= index($_, $char), keys %blocks;
    for my $candidate (@candidates) {
        next if $blocks{$candidate} <= 0;
        local $blocks{$candidate} = $blocks{$candidate} - 1;
        return 1 if q() eq $word or _can_make_word($word, %blocks);
    }
    return
}


sequence blocks, words, used

function ABC_Solve(sequence word, integer idx)
integer ch, res = 0
    if idx>length(word) then
        res = 1
-- or:  res = length(word)>0 -- (if "" -> false desired)
    else
        ch = word[idx]
        for k=1 to length(blocks) do
            if used[k]=0
            and find(ch,blocks[k]) then
                used[k] = 1
                res = ABC_Solve(word,idx+1)
                used[k] = 0
                if res then exit end if
            end if
        end for
    end if
    return res
end function

constant tests = {{{"BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS",
                    "JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"},
                   {"","A","BarK","BOOK","TrEaT","COMMON","SQUAD","CONFUSE"}},
                  {{"US","TZ","AO","QA"},{"AuTO"}},
                  {{"AB","AB","AC","AC"},{"abba"}}}

for i=1 to length(tests) do
    {blocks,words} = tests[i]
    used = repeat(0,length(blocks))
    for j=1 to length(words) do
        printf(1,"%s: %t\n",{words[j],ABC_Solve(upper(words[j]),1)})
    end for
end for


<?php
$words = array("A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "Confuse");

function canMakeWord($word) {
    $word = strtoupper($word);
    $blocks = array(
            "BO", "XK", "DQ", "CP", "NA",
            "GT", "RE", "TG", "QD", "FS",
            "JW", "HU", "VI", "AN", "OB",
            "ER", "FS", "LY", "PC", "ZM",
    );

    foreach (str_split($word) as $char) {
        foreach ($blocks as $k => $block) {
            if (strpos($block, $char) !== FALSE) {
                unset($blocks[$k]);
                continue(2);
            }
        }
        return false;
    }
    return true;
}

foreach ($words as $word) {
    echo $word.': ';
    echo canMakeWord($word) ? "True" : "False";
    echo "\r\n";
}


go =>
  test_it(check_word),
  test_it(check_word2),
  nl.

% Get all possible solutions (via fail)
go2 ?=>
  test_version(check_word2),
  fail,
  nl.
go2 => true.

%
% Test a version.
%
test_it(Pred) =>
  println(testing=Pred),
  Blocks = findall([A,B], block(A,B)),
  Words = findall(W,word(W)),
  foreach(Word in Words)
     println(word=Word),
     ( call(Pred,Word,Blocks) ;  println("Cannot make word.")),
     nl
  end,
  nl.

%
% Picat style: Using nth/3 for getting the chars
%
check_word(Word, Blocks) =>
  WordC = atom_chars(Word), % convert atom to string
  WordLen = length(WordC),
  X = new_list(WordLen),
  Pos = new_list(WordLen),
  foreach(I in 1..WordLen)
    % find a character at the specific position
    nth(X[I],Blocks,XI),
    nth(Pos[I],XI, WordC[I])
  end,
  alldiff(X), % ensure unique selection
  foreach(I in 1..WordLen)
    println([WordC[I], Blocks[X[I]]])
  end,
  nl.

%
% Prolog style (recursive) version using select/3.
% (where we don't have to worry about duplicate blocks)
%
check_word2(Word, Blocks) :-
  pick_block(atom_chars(Word),Blocks,[],X),
  println(X).

pick_block([], _,Res,Res).
pick_block([C|WordRest], Blocks, Res1,[Block|Res]) :-
  % pick (non-deterministically) one of the blocks
  select(Block,Blocks,BlocksRest),
  membchk(C,Block),
  pick_block(WordRest,BlocksRest,Res1,Res).

%
% alldiff(L):
%   ensure that all elements in L are different
%
alldiff([]).
alldiff([_]).
alldiff([H|T]) :-
   neq(H,T),
   alldiff(T).

neq(_,[]).
neq(X,[H|T]) :-
  X != H,
  neq(X,T).

% The words to check.
word(a).
word(bark).
word(book).
word(treat).
word(common).
word(squad).
word(confuse).
word(auto).
word(abba).
word(coestablishment).
word(schoolmastering).

% The blocks
block(b,o).
block(x,k).
block(d,q).
block(c,p).
block(n,a).
block(g,t).
block(r,e).
block(t,g).
block(q,d).
block(f,s).
block(j,w).
block(h,u).
block(v,i).
block(a,n).
block(o,b).
block(e,r).
block(f,s).
block(l,y).
block(p,c).
block(z,m).


(setq *Blocks
   '((B O) (X K) (D Q) (C P) (N A) (G T) (R E)
   (T G) (Q D) (F S) (J W) (H U) (V I) (A N)
   (O B) (E R) (F S) (L Y) (P C) (Z M) ) )
(setq *Words '("" "1" "A" "BARK" "BOOK" "TREAT"
               "Bbb" "COMMON" "SQUAD" "Confuse"
               "abba" "ANBOCPDQERSFTGUVWXLZ") )

(de abc (W B)
   (let Myblocks (copy B)
      (fully
         '((C)
            (when (seek '((Lst) (member C (car Lst))) Myblocks)
               (set @)
               T ) )
      (chop (uppc W)) ) ) )

(de abcR (W B)
   (nond
      ((car W) T)
      ((car B) NIL)
      (NIL
         (setq W (chop W))
         (let? I
            (find
               '((Lst) (member (uppc (car W)) Lst))
               B )
            (abcR (cdr W) (delete I B)) ) ) ) )

(for Word *Words
   (println Word (abc Word *Blocks) (abcR Word *Blocks)) )

(bye)


ABC: procedure options (main);   /* 12 January 2014 */

   declare word character (20) varying, blocks character (200) varying initial
      ('((B O) (X K) (D Q) (C P) (N A) (G T) (R E) (T G) (Q D) (F S)
        (J W) (H U) (V I) (A N) (O B) (E R) (F S) (L Y) (P C) (Z M))');
   declare tblocks character (200) varying;
   declare (true value ('1'b), false value ('0'b), flag) bit (1);
   declare ch character (1);
   declare (i, k) fixed binary;

   do word = 'A', 'BARK', 'BOOK', 'TREAT', 'COMMON', 'SQuAd', 'CONFUSE';
      flag = true;
      tblocks = blocks;
      do i = 1 to length(word)
      while(flag = true);
         ch = substr(word, i, 1);
         k = index(tblocks, uppercase(ch));
         if k = 0 then
            flag = false;
         else /* Found a block with the letter on it. */
            substr(tblocks, k-1, 4) = '   '; /* Delete the block. */
      end;
      if flag then put skip list (word, 'true'); else put skip list (word, 'false');
   end;

end ABC;


100H:

/* ABC PROBLEM ON $-TERMINATED STRING */
CAN$MAKE$WORD: PROCEDURE (STRING) BYTE;
    DECLARE STRING ADDRESS, CHAR BASED STRING BYTE;
    DECLARE CONST$BLOCKS DATA
                ('BOKXDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM');
    DECLARE I BYTE, BLOCKS (40) BYTE;

    DO I=0 TO 39; /* MAKE COPY OF BLOCKS */
        BLOCKS(I) = CONST$BLOCKS(I);
    END;

    STEP: DO WHILE CHAR <> '$';
        DO I=0 TO 39; /* FIND BLOCK WITH CURRENT CHAR */
            IF BLOCKS(I) = CHAR THEN DO; /* FOUND IT */
                BLOCKS(I) = 0; /* CLEAR OUT BOTH LETTERS ON BLOCK */
                BLOCKS(I XOR 1) = 0;
                STRING = STRING + 1;
                GO TO STEP; /* NEXT CHARACTER */
            END;
        END;
        RETURN 0; /* NO BLOCK WITH LETTER */
    END;

    RETURN 1; /* WE FOUND THEM ALL */
END CAN$MAKE$WORD;

/* CP/M BDOS CALL */
BDOS: PROCEDURE (FN, ARG);
    DECLARE FN BYTE, ARG ADDRESS;
    GO TO 5;
END BDOS;

PRINT: PROCEDURE (STRING);
    DECLARE STRING ADDRESS;
    CALL BDOS(9, STRING);
END PRINT;

/* TEST SEVERAL STRINGS */
DECLARE TEST (7) ADDRESS, I BYTE;
TEST(0) = .'A$';
TEST(1) = .'BARK$';
TEST(2) = .'BOOK$';
TEST(3) = .'TREAT$';
TEST(4) = .'COMMON$';
TEST(5) = .'SQUAD$';
TEST(6) = .'CONFUSE$';

DO I = 0 TO LAST(TEST);
    CALL PRINT(TEST(I));
    CALL PRINT(.': $');
    IF CAN$MAKE$WORD(TEST(I))
        THEN CALL PRINT(.'YES$');
        ELSE CALL PRINT(.'NO$');
    CALL PRINT(.(13,10,'$'));
END;

CALL BDOS(0,0);
EOF


#COMPILE EXE
#DIM ALL
'
' A B C p r o b l e m . b a s
'
' by  Geary Chopoff
' for Chopoff Consulting and RosettaCode.org
' on  2014Jul23
'
'2014Jul23
'
'You are given a collection of ABC blocks. Just like the ones you had when you were a kid.
'There are twenty blocks with two letters on each block. You are guaranteed to have a complete
'alphabet amongst all sides of the blocks. The sample blocks are:
'((B O) (X K) (D Q) (C P) (N A) (G T) (R E) (T G) (Q D) (F S) (J W) (H U) (V I) (A N) (O B) (E R) (F S) (L Y) (P C) (Z M))
'The goal of this task is to write a function that takes a string and can determine whether
'you can spell the word with the given collection of blocks.
'
'The rules are simple:
'1.Once a letter on a block is used that block cannot be used again
'2.The function should be case-insensitive
'3. Show your output on this page for the following words:
'	A, BARK, BOOK, TREAT, COMMON, SQUAD, CONFUSE
'-----------------------------------------------------------------------------
' G l o b a l   C o n s t a n t s
'
%Verbose = 0                'make this 1 to have a lot of feedback
%MAX_BLOCKS = 20            'total number of blocks
%MAX_SIDES = 2              'total number of sides containing a unique letter per block

%MAX_ASC = 255
%FALSE = 0                  'this is correct because there is ONLY ONE value for FALSE
%TRUE  = (NOT %FALSE)       'this is one of MANY values of TRUE!
$FLAG_TRUE = "1"
$FLAG_FALSE = "0"
'-----------------------------------------------------------------------------
' G l o b a l   V a r i a b l e s
'
GLOBAL blk() AS STRING
'-----------------------------------------------------------------------------
'i n i t B l o c k s
'
' as we will use this array only once we build it each time program is run
'
SUB initBlocks
 LOCAL j AS INTEGER
    j=1
    blk(j)="BO"
    j=j+1
    blk(j)="XK"
    j=j+1
    blk(j)="DQ"
    j=j+1
    blk(j)="CP"
    j=j+1
    blk(j)="NA"
    j=j+1
    blk(j)="GT"
    j=j+1
    blk(j)="RE"
    j=j+1
    blk(j)="TG"
    j=j+1
    blk(j)="QD"
    j=j+1
    blk(j)="FS"
    j=j+1
    blk(j)="JW"
    j=j+1
    blk(j)="HU"
    j=j+1
    blk(j)="VI"
    j=j+1
    blk(j)="AN"
    j=j+1
    blk(j)="OB"
    j=j+1
    blk(j)="ER"
    j=j+1
    blk(j)="FS"
    j=j+1
    blk(j)="LY"
    j=j+1
    blk(j)="PC"
    j=j+1
    blk(j)="ZM"
    IF j <> %MAX_BLOCKS THEN
        STDOUT "initBlocks:Error: j is not same as MAX_BLOCKS!",j,%MAX_BLOCKS
    END IF
END SUB
'-----------------------------------------------------------------------------
' m a k e W o r d
'
FUNCTION makeWord(tryWord AS STRING) AS BYTE
 LOCAL retTF AS BYTE
 LOCAL j AS INTEGER
 LOCAL s AS INTEGER         'which side of block we are looking at
 LOCAL k AS INTEGER
 LOCAL c AS STRING          'character in tryWord we are looking for

    FOR j = 1 TO LEN(tryWord)
        c = UCASE$(MID$(tryWord,j,1))   'character we want to show with block

        retTF = %FALSE                  'we assume this will fail

        FOR k = 1 TO %MAX_BLOCKS
            IF LEN(blk(k)) = %MAX_SIDES THEN
                FOR s = 1 TO %MAX_SIDES
                    IF c = MID$(blk(k),s,1) THEN
                        retTF = %TRUE   'this block has letter we want
                        blk(k) = ""     'remove this block from further consideration
                        EXIT FOR
                    END IF
                NEXT s
            END IF
            IF retTF THEN EXIT FOR      'can go on to next character in word
        NEXT k
        IF ISFALSE retTF THEN EXIT FOR  'if character not found then all is done
    NEXT j

    FUNCTION = retTF
END FUNCTION
'-----------------------------------------------------------------------------
' P B M A I N
'
FUNCTION PBMAIN () AS LONG
 DIM blk(1 TO %MAX_BLOCKS, 1 TO %MAX_SIDES) AS STRING
 LOCAL cmdLine AS STRING

    initBlocks              'setup global array of blocks

    cmdLine=COMMAND$
    IF LEN(cmdLine)= 0 THEN
        STDOUT "Useage for ABCproblem Version 1.00:"
        STDOUT ""
        STDOUT "     >ABCproblem tryThisWord"
        STDOUT ""
        STDOUT "Where tryThisWord is a word you want to see if"+STR$(%MAX_BLOCKS)+" blocks can make."
        STDOUT "If word can be made TRUE is returned."
        STDOUT "Otherwise FALSE is returned."
        EXIT FUNCTION
    END IF

    IF INSTR(TRIM$(cmdLine)," ") = 0 THEN
        IF makeWord(cmdLine) THEN
            STDOUT "TRUE"
        ELSE
            STDOUT "FALSE"
        END IF
    ELSE
        STDOUT "Error:Missing word to try to make with blocks!  <" & cmdLine & ">"
        EXIT FUNCTION
    END IF
END FUNCTION


<#
.Synopsis
  ABC Problem
.DESCRIPTION
   You are given a collection of ABC blocks. Just like the ones you had when you were a kid.
   There are twenty blocks with two letters on each block. You are guaranteed to have a
   complete alphabet amongst all sides of the blocks
   blocks = "BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS","JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"
   The goal of this task is to write a function that takes a string and can determine whether
   you can spell the word with the given collection of blocks.

   The rules are simple:
        1.Once a letter on a block is used that block cannot be used again
        2.The function should be case-insensitive
        3. Show your output on this page for the following words:
        >>> can_make_word("A")
        True
        >>> can_make_word("BARK")
        True
        >>> can_make_word("BOOK")
        False
        >>> can_make_word("TREAT")
        True
        >>> can_make_word("COMMON")
        False
        >>> can_make_word("SQUAD")
        True
        >>> can_make_word("CONFUSE")
        True

   Using the examples below  you can either see just the value or
   status and the values using the verbose switch

.EXAMPLE
   test-blocks -testword confuse

.EXAMPLE
   test-blocks -testword confuse -verbose

#>

function test-blocks
{
	[CmdletBinding()]
	#  [OutputType([int])]
	Param
	(
		# word to test against blocks
		[Parameter(Mandatory = $true,
				   ValueFromPipelineByPropertyName = $true)]
		$testword

	)

	$word = $testword

	#define array of blocks
	[System.Collections.ArrayList]$blockarray = "BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"

	#send word to chararray
	$chararray = $word.ToCharArray()
	$chars = $chararray

	#get the character count
	$charscount = $chars.count

	#get the initial count of the blocks
	$blockcount = $blockarray.Count

	#find out how many blocks should be left from the difference
	#of the blocks and characters in the word - 1 letter/1 block
	$correctblockcount = $blockcount - $charscount

	#loop through the characters in the word
	foreach ($char in $chars)
	{

		#loop through the blocks
		foreach ($block in $blockarray)
		{

			#check the current character against each letter on the current block
			#and break if found so the array can reload
			if ($char -in $block[0] -or $char -in $block[1])
			{

				write-verbose "match for letter - $char - removing block $block"
				$blockarray.Remove($block)
				break

			}

		}

	}
	#get final count of blocks left in array to determine if the word was
	#correctly made
	$finalblockcount = $blockarray.count
	if ($finalblockcount -ne $correctblockcount)
	{
		write-verbose "$word : $false "
		return $false
	}
	else
	{
		write-verbose "$word : $true "
		return $true
	}

}

#loop all the words and pass them to the function
$wordlist = "a", "bark", "book", "treat", "common", "squad", "confuse"
foreach ($word in $wordlist)
{
	test-blocks -testword $word -Verbose
}


abc_problem :-
	maplist(abc_problem, ['', 'A', bark, bOOk, treAT, 'COmmon', sQuaD, 'CONFUSE']).

abc_problem(Word) :-
	L = [[b,o],[x,k],[d,q],[c,p],[n,a],[g,t],[r,e],[t,g],[q,d],[f,s],
	     [j,w],[h,u],[v,i],[a,n],[o,b],[e,r],[f,s],[l,y],[p,c],[z,m]],

	(   abc_problem(L, Word)
	->  format('~w OK~n', [Word])
	;   format('~w KO~n', [Word])).

abc_problem(L, Word) :-
	atom_chars(Word, C_Words),
	maplist(downcase_atom, C_Words, D_Words),
	can_makeword(L, D_Words).

can_makeword(_L, []).

can_makeword(L, [H | T]) :-
	(   select([H, _], L, L1); select([_, H], L, L1)),
	can_makeword(L1, T).


EnableExplicit
#LETTERS = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM "

Procedure.s can_make_word(word.s)
  Define letters.s = #LETTERS, buffer.s
  Define index1.i, index2.i
  Define match.b
  For index1=1 To Len(word)
    index2=1 : match=#False
    Repeat
      buffer=StringField(letters,index2,Space(1))
      If FindString(buffer,Mid(word,index1,1),1,#PB_String_NoCase)
        letters=RemoveString(letters,buffer+Chr(32),0,1,1)
        match=#True
        Break
      EndIf
      index2+1
    Until index2>CountString(letters,Space(1))
    If Not match : ProcedureReturn word+#TAB$+"FALSE" : EndIf
  Next
  ProcedureReturn word+#TAB$+"TRUE"
EndProcedure

OpenConsole()
PrintN(can_make_word("a"))
PrintN(can_make_word("BaRK"))
PrintN(can_make_word("BOoK"))
PrintN(can_make_word("TREAt"))
PrintN(can_make_word("cOMMON"))
PrintN(can_make_word("SqUAD"))
PrintN(can_make_word("COnFUSE"))
Input()


'''
Note that this code is broken, e.g., it won't work when
blocks = [("A", "B"), ("A","C")] and the word is "AB", where the answer
should be True, but the code returns False.
'''
blocks = [("B", "O"),
          ("X", "K"),
          ("D", "Q"),
          ("C", "P"),
          ("N", "A"),
          ("G", "T"),
          ("R", "E"),
          ("T", "G"),
          ("Q", "D"),
          ("F", "S"),
          ("J", "W"),
          ("H", "U"),
          ("V", "I"),
          ("A", "N"),
          ("O", "B"),
          ("E", "R"),
          ("F", "S"),
          ("L", "Y"),
          ("P", "C"),
          ("Z", "M")]

def can_make_word(word, block_collection=blocks):
    """
    Return True if `word` can be made from the blocks in `block_collection`.

    >>> can_make_word("")
    False
    >>> can_make_word("a")
    True
    >>> can_make_word("bark")
    True
    >>> can_make_word("book")
    False
    >>> can_make_word("treat")
    True
    >>> can_make_word("common")
    False
    >>> can_make_word("squad")
    True
    >>> can_make_word("coNFused")
    True
    """
    if not word:
        return False

    blocks_remaining = block_collection[:]
    for char in word.upper():
        for block in blocks_remaining:
            if char in block:
                blocks_remaining.remove(block)
                break
        else:
            return False
    return True

if __name__ == "__main__":
    import doctest
    doctest.testmod()
    print(", ".join("'%s': %s" % (w, can_make_word(w)) for w in
                    ["", "a", "baRk", "booK", "treat",
                     "COMMON", "squad", "Confused"]))


V cache = [[BigInt(1)]]
F cumu(n)
   L(l) :cache.len .. n
      V r = [BigInt(0)]
      L(x) 1 .. l
         r.append(r.last + :cache[l - x][min(x, l - x)])
      :cache.append(r)
   R :cache[n]

F row(n)
   V r = cumu(n)
   R (0 .< n).map(i -> @r[i + 1] - @r[i])

print(‘rows:’)
L(x) 1..10
   print(‘#2:’.format(x)‘ ’row(x))

print("\nsums:")

V pp = [BigInt(1)]

F partitions(n)
   :pp.append(BigInt(0))

   L(k) 1 .. n
      V d = n - k * (3 * k - 1) I/ 2
      I d < 0
         L.break

      I k [&] 1 != 0
         :pp[n] += :pp[d]
      E
         :pp[n] -= :pp[d]

      d -= k
      I d < 0
         L.break

      I k [&] 1 != 0
         :pp[n] += :pp[d]
      E
         :pp[n] -= :pp[d]

   R :pp.last

V ns = Set([23, 123, 1234, 12345])
V max_ns = max(ns)

L(i) 1 .. max_ns
   I i > max_ns
      L.break
   V p = partitions(i)
   I i C ns
      print(‘#6: #.’.format(i, p))


BLOCKS:string`BO`XK`DQ`CP`NA`GT`RE`TG`QD`FS`JW`HU`VI`AN`OB`ER`FS`LY`PC`ZM
WORDS:string`A`BARK`BOOK`TREAT`COMMON`SQUAD`CONFUSE

cmw:{[s;b]                                                   / [str;blocks]
  $[0=count s; 1b;                                           /   empty string
    not any found:any each b=s 0; 0b;                        /   cannot proceed
    any(1_s).z.s/:b(til count b)except/:where found] }


[ $ "BOXKDQCPNAGTRETGQDFS"
  $ "JWHUVIANOBERFSLYPCZM"
  join ] constant          is blocks        (     --> $ )

[ -2 &
  tuck pluck drop
  swap pluck drop ]        is remove2       ( $ n --> $ )

[ iff [ say "True" ]
  else [ say "False" ] ]   is echotruth     (   b -->   )

[ true blocks rot
  witheach
    [ upper over find
      2dup swap found
      iff remove2
      else
        [ drop dip not
          conclude ] ]
  drop echotruth ]        is can_make_word (   $ -->   )