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

September 2017 Update

Browse source
This commit is contained in:
Ingy döt Net 2017-09-23 10:01:46 +02:00
parent bba7bfd280
commit ba8067c3b7
14570 changed files with 153136 additions and 63871 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -0,0 +1,76 @@
* ABC Problem 21/07/2016
ABC CSECT
USING ABC,R13 base register
B 72(R15) skip savearea
DC 17F'0' savearea
STM R14,R12,12(R13) prolog
ST R13,4(R15) " <-
ST R15,8(R13) " ->
LR R13,R15 " addressability
LA R8,1 l=1
LOOPL C R8,=A(NN) do l=1 to hbound(words)
BH ELOOPL
LR R1,R8 l
MH R1,=H'20' *20
LA R10,WORDS-20(R1) @words(l)
MVC STATUS,=CL5'true' cflag='true'
MVC TBLOCKS,BLOCKS tblocks=blocks
MVC CC(1),0(R10) cc=substr(words(l),1,1)
LA R6,1 i=1
LOOPI CLI CC,C' ' do while cc<>' '
BE ELOOPI
SR R7,R7 k=0
LH R0,=H'1' m=1
LOOPM CH R0,=AL2(L'TBLOCKS) do m=1 to length(tblocks)
BH ELOOPM
LA R5,TBLOCKS-1 @tblocks[0]
AR R5,R0 @tblocks[m]
CLC 0(1,R5),CC if substr(tblocks,m,1)=cc
BNE INDEXM
LR R7,R0 k=m=index(tblocks,cc)
B ELOOPM
INDEXM AH R0,=H'1' m=m+1
B LOOPM
ELOOPM LTR R7,R7 if k=0
BNZ OKK
MVC STATUS,=CL5'false' cflag='false'
B EIFK0
OKK LA R4,TBLOCKS-2 @tblocks[-1]
AR R4,R7 +k
CLI 0(R4),C'(' if substr(tblocks,k-1,1)='('
BNE SECOND
LA R0,1 j=1
B EIFBLOCK
SECOND LA R0,3 j=3
EIFBLOCK LR R2,R7 k
SR R2,R0 k-j
LA R4,TBLOCKS-1 @tblocks[0]
AR R4,R2 @tblocks[k-j]
MVC 0(5,R4),=CL5' ' substr(tblocks,k-j,5)=' '
EIFK0 LA R6,1(R6) i=i+1
LR R4,R10 @words
AR R4,R6 +i
BCTR R4,0 -1
MVC CC,0(R4) cc=substr(words,i,1)
B LOOPI
ELOOPI MVC PG(20),0(R10) tabword(l)
MVC PG+20(5),STATUS status
XPRNT PG,80 print buffer
LA R8,1(R8) l=l+1
B LOOPL
ELOOPL L R13,4(0,R13) epilog
LM R14,R12,12(R13) " restore
XR R15,R15 " rc=0
BR R14 exit
WORDS DC CL20'A',CL20'BARK',CL20'BOOK',CL20'TREAT',CL20'COMMON'
DC CL20'SQUAD',CL20'CONFUSE'
BLOCKS DS 0CL122
DC CL61'((B O) (X K) (D Q) (C P) (N A) (G T) (R E) (T G) (Q D) (F S) '
DC CL61'(J W) (H U) (V I) (A N) (O B) (E R) (F S) (L Y) (P C) (Z M)) '
TBLOCKS DS CL(L'BLOCKS) work blocks
CC DS CL1 letter to find
STATUS DS CL5 true/false
PG DC CL80' ' buffer
YREGS
NN EQU (BLOCKS-WORDS)/L'WORDS number of words
END ABC

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

@ -0,0 +1,198 @@
\ ========================================================================================
\ You are given a collection of ABC blocks
\ There are twenty blocks with two letters on each block.
\ A complete alphabet is guaranteed amongst all sides of the blocks.
\
\ Write a function that takes a string (word) and determines whether
\ the word can be spelled with the given collection of blocks.
\
\ Rules:
\ 1. Once a letter on a block is used that block cannot be used again
\ 2. The function should be case-insensitive
\ 3. Show the output on this page for the following 7 words in the following example
\ can_make_word(???) where ??? is resp.:
\ "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"
\
\ NOTE:
\ to make the program readable for even n00bs, I have a comment at the end of each line.
\ The comments take the form of:
\ \ <stack> | <rstack>
\ in order to be able to follow exactly what the program does.
\ ========================================================================================
["BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS","JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"] var, blks
["a", "AbBa", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"] var, chkwrds
needs stack/rstack
a:new var, paths \ Keeps the combinatory explosion of letter paths
var wrd
var success
var ix
: uni2char "" swap s:+ ;
: char2uni 0 s:@ nip ;
: rreset rstack st:clear drop ;
: addoneletter \ ix path -- \ ix path | letter
r@ \ ix path letter | letter
s:+ \ ix newpath | letter
paths @ \ ix newpath paths | letter
-rot \ paths ix newval | letter
a:! \ paths | letter
drop \ | letter
;
: oneletter \ letter -- \ letter
>r \ | letter
paths @ ' addoneletter a:each drop \ | letter
;
: addtwoletters \ ix path -- \ ix path | letter1 letter2 halflen
swap \ path ix | letter1 letter2 halflen
dup \ path ix ix | letter1 letter2 halflen
r@ \ path ix ix halflen | letter1 letter2 halflen
n:< \ path ix bool | letter1 letter2 halflen
if \ path ix | letter1 letter2 halflen
swap \ ix path | letter1 letter2 halflen
1 rpick \ ix path letter | letter1 letter2 halflen
else
swap \ ix path | letter1 letter2 halflen
2 rpick \ ix path letter | letter1 letter2 halflen
then
s:+ \ ix newpath | letter1 letter2 halflen
paths @ \ ix newpath paths | letter1 letter2 halflen
-rot \ paths ix newpath | letter1 letter2 halflen
a:! \ paths | letter1 letter2 halflen
drop \ | letter1 letter2 halflen
;
: twoletters \ letters -- \ letters
\ fetch the 2 letters
dup \ letters letters
1 s:lsub \ letters letter1
>r \ letters | letter1
1 s:rsub \ letter2 | letter1
>r \ | letter1 letter2
\ duplicate paths in itself
paths @ dup a:+ \ paths | letter1 letter2
\ halfway length of array
a:len \ paths len | letter1 letter2
2 / \ paths halflen | letter1 letter2
>r \ paths | letter1 letter2 halflen
\ add letters to paths
' addtwoletters a:each drop \ | letter1 letter2 halflen
rreset \
;
: chkletter \ letter -- letter \ letter
dup \ letter letter
wrd @ \ letter letter word
swap uni2char \ letter word letter
s:search \ letter word index
null? \ letter word index bool
nip \ letter word bool
if \ letter word
2drop \
"" \ letter
else \ letter word
drop \ letter
then \
;
: buildpaths \ ix blk -- \ ix blk
nip \ blk
' chkletter s:map \ resultletters
s:len \ resultletters len
dup \ resultletters len len
0 \ resultletters len len 0
n:= \ resultletters len bool
if \ resultletters len
\ This block contains no letters of current word
2drop \
;; \ exit word
then \ resultletters len
1 \ resultletters len 1
n:= \ resultletters bool
if \ resultletters
oneletter \
else \ resultletters
twoletters \
then
;
: chkokpath \ ix wrdch -- \ ix wrdch | path
swap \ wrdch ix | path
ix ! \ wrdch | path
r@ \ wrdch path | path
dup \ wrdch path path | path
"" \ wrdch path path "" | path
s:= \ wrdch path bool | path
if \ wrdch path | path
\ Path is empty - no match
2drop \ | path
break \ | path
;; \ | path
then
swap \ path wrdch | path
uni2char \ path wrdch | path
s:search \ path pos | path
null? \ path pos bool | path
if \ path pos | path
\ Letter not found in path - no match
2drop \ | path
break \ | path
else \ path pos | path
wrd @ \ path pos wrd | path
s:len \ path pos wrd len | path
nip \ path pos len | path
n:1- \ path pos cix | path
ix @ \ path pos cix ix | path
n:= \ path pos bool | path
if \ path pos | path
\ We have a match!
true success ! \ path pos | path
2drop \ | path
break \ | path
else \ path pos | path
1 \ path pos len | path
s:- \ restpath | path
rdrop >r \ | restpath
then
then
;
: chkpath \ ix path -- \ ix path
nip \ path
>r \ | path
wrd @ \ wrd | path
' chkokpath s:each \ | path
rdrop \
success @ \ success
if \
break \
then
;
: chkwrd \ ix wrd -- \ ix wrd
nip \ wrd
s:uc \ wrdupper
"Word=" . dup . \ wrdupper
wrd ! \
\ other word - clear paths
paths @ a:clear "" a:push drop \
\ create path tree for this word
blks @ ' buildpaths a:each drop \
\ check if word can be made from a path
false success ! \
paths @ ' chkpath a:each drop \
success @ \ success
"\t\t" . . cr \
;
: app:main
chkwrds @ ' chkwrd a:each drop \ check if word can be made
bye
;

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

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

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

@ -0,0 +1,28 @@
set blocks to {"bo", "xk", "dq", "cp", "na", "gt", "re", "tg", "qd", "fs", ¬
"jw", "hu", "vi", "an", "ob", "er", "fs", "ly", "pc", "zm"}
canMakeWordWithBlocks("a", blocks)
canMakeWordWithBlocks("bark", blocks)
canMakeWordWithBlocks("book", blocks)
canMakeWordWithBlocks("treat", blocks)
canMakeWordWithBlocks("common", blocks)
canMakeWordWithBlocks("squad", blocks)
canMakeWordWithBlocks("confuse", blocks)
on canMakeWordWithBlocks(theString, constBlocks)
copy constBlocks to theBlocks
if theString = "" then return true
set i to 1
repeat
if i > (count theBlocks) then exit repeat
if character 1 of theString is in item i of theBlocks then
set item i of theBlocks to missing value
set theBlocks to strings of theBlocks
if canMakeWordWithBlocks(rest of characters of theString as string, theBlocks) then
return true
end if
end if
set i to i + 1
end repeat
return false
end canMakeWordWithBlocks

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

@ -0,0 +1,242 @@
use framework "Foundation"
-- SPELLING BY BLOCK ----------------------------------------------------------
on run
set blocks to map(chars, ¬
|words|("BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM"))
script blockSpelled
on |λ|(s)
intercalate(" -> ", ¬
ap({my |quote|, compose({my |not|, my |null|, ¬
curry(my spellWith)'s |λ|(blocks), my toUpper})}, {s}))
end |λ|
end script
unlines(map(blockSpelled, ¬
{"", "A", "BARK", "BoOK", "TrEAT", "COmMoN", "SQUAD", "conFUsE"}))
end run
-- spellWith :: [(Char, Char)] -> String -> [[(Char, Char)]]
on spellWith(blocks, ccs)
if |null|(ccs) then
{{}}
else
set {c, cs} to uncons(ccs)
script matchSequence
on |λ|(pair)
if elem(c, pair) then
script pairUsed
on |λ|(xs)
{{pair} & xs}
end |λ|
end script
concatMap(pairUsed, spellWith(|delete|(pair, blocks), cs))
else
{}
end if
end |λ|
end script
concatMap(matchSequence, blocks)
end if
end spellWith
-- GENERIC FUNCTIONS ----------------------------------------------------------
-- A list of functions applied to a list of arguments
-- (<*> | ap) :: [(a -> b)] -> [a] -> [b]
on ap(fs, xs)
set lngFs to length of fs
set lngXs to length of xs
set lst to {}
repeat with i from 1 to lngFs
tell mReturn(item i of fs)
repeat with j from 1 to lngXs
set end of lst to |λ|(contents of (item j of xs))
end repeat
end tell
end repeat
return lst
end ap
-- chars :: String -> [Char]
on chars(s)
characters of s
end chars
-- compose :: [(a -> a)] -> (a -> a)
on compose(fs)
script
on |λ|(x)
script
on |λ|(a, f)
mReturn(f)'s |λ|(a)
end |λ|
end script
foldr(result, x, fs)
end |λ|
end script
end compose
-- concatMap :: (a -> [b]) -> [a] -> [b]
on concatMap(f, xs)
set lst to {}
set lng to length of xs
tell mReturn(f)
repeat with i from 1 to lng
set lst to (lst & |λ|(contents of item i of xs, i, xs))
end repeat
end tell
return lst
end concatMap
-- curry :: (Script|Handler) -> Script
on curry(f)
script
on |λ|(a)
script
on |λ|(b)
|λ|(a, b) of mReturn(f)
end |λ|
end script
end |λ|
end script
end curry
-- delete :: Eq a => a -> [a] -> [a]
on |delete|(x, xs)
set mbIndex to elemIndex(x, xs)
set lng to length of xs
if mbIndex is not missing value then
if lng > 1 then
if mbIndex = 1 then
items 2 thru -1 of xs
else if mbIndex = lng then
items 1 thru -2 of xs
else
tell xs to items 1 thru (mbIndex - 1) & ¬
items (mbIndex + 1) thru -1
end if
else
{}
end if
else
xs
end if
end |delete|
-- elem :: Eq a => a -> [a] -> Bool
on elem(x, xs)
xs contains x
end elem
-- elemIndex :: a -> [a] -> Maybe Int
on elemIndex(x, xs)
set lng to length of xs
repeat with i from 1 to lng
if x = (item i of xs) then return i
end repeat
return missing value
end elemIndex
-- foldr :: (a -> b -> a) -> a -> [b] -> a
on foldr(f, startValue, xs)
tell mReturn(f)
set v to startValue
set lng to length of xs
repeat with i from lng to 1 by -1
set v to |λ|(v, item i of xs, i, xs)
end repeat
return v
end tell
end foldr
-- intercalate :: Text -> [Text] -> Text
on intercalate(strText, lstText)
set {dlm, my text item delimiters} to {my text item delimiters, strText}
set strJoined to lstText as text
set my text item delimiters to dlm
return strJoined
end intercalate
-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
tell mReturn(f)
set lng to length of xs
set lst to {}
repeat with i from 1 to lng
set end of lst to |λ|(item i of xs, i, xs)
end repeat
return lst
end tell
end map
-- null:: [a] -> Bool
on |null|(xs)
if class of xs is string then
xs = ""
else
xs = {}
end if
end |null|
-- Lift 2nd class handler function into 1st class script wrapper
-- mReturn :: Handler -> Script
on mReturn(f)
if class of f is script then
f
else
script
property |λ| : f
end script
end if
end mReturn
-- not :: Bool -> Bool
on |not|(x)
not x
end |not|
-- quote :: String -> String
on |quote|(x)
quoted form of x
end |quote|
-- toUpper :: String -> String
on toUpper(str)
set ca to current application
((ca's NSString's stringWithString:(str))'s ¬
uppercaseStringWithLocale:(ca's NSLocale's currentLocale())) as text
end toUpper
-- uncons :: [a] -> Maybe (a, [a])
on uncons(xs)
set lng to length of xs
if lng > 0 then
if class of xs is string then
set cs to text items of xs
{item 1 of cs, rest of cs}
else
{item 1 of xs, rest of xs}
end if
else
missing value
end if
end uncons
-- unlines :: [String] -> String
on unlines(xs)
intercalate(linefeed, xs)
end unlines
-- words :: String -> [String]
on |words|(s)
words of s
end |words|

27
Task/ABC-Problem/AppleScript/abc-problem.applescript
View file

@ -1,27 +0,0 @@
set blocks to {"bo", "xk", "dq", "cp", "na", "gt", "re", "tg", "qd", "fs", "jw", "hu", "vi", "an", "ob", "er", "fs", "ly", "pc", "zm"}
canMakeWordWithBlocks("a", blocks)
canMakeWordWithBlocks("bark", blocks)
canMakeWordWithBlocks("book", blocks)
canMakeWordWithBlocks("treat", blocks)
canMakeWordWithBlocks("common", blocks)
canMakeWordWithBlocks("squad", blocks)
canMakeWordWithBlocks("confuse", blocks)
on canMakeWordWithBlocks(theString, constBlocks)
copy constBlocks to theBlocks
if theString = "" then return true
set i to 1
repeat
if i > (count theBlocks) then exit repeat
if character 1 of theString is in item i of theBlocks then
set item i of theBlocks to missing value
set theBlocks to strings of theBlocks
if canMakeWordWithBlocks(rest of characters of theString as string, theBlocks) then
return true
end if
end if
set i to i + 1
end repeat
return false
end canMakeWordWithBlocks

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

@ -0,0 +1,12 @@
fun abc(s, list):
return true if s.empty
for i in [:list.size]:
return any([abc(s[:!1], delete(val list, i))]) ...
if s[!0] in list[i] else true
false
let test = ["A", "BARK","BOOK","TREAT","COMMON","SQUAD","CONFUSE"]
let list = ["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))"

0
Task/ABC-Problem/BASIC/abc-problem.basic → Task/ABC-Problem/BASIC/abc-problem-1.basic
View file

25
Task/ABC-Problem/BASIC/abc-problem-2.basic Normal file
View file

@ -0,0 +1,25 @@
10 W$ = "A" : GOSUB 100
20 W$ = "BARK" : GOSUB 100
30 W$ = "BOOK" : GOSUB 100
40 W$ = "TREAT" : GOSUB 100
50 W$ = "COMMON" : GOSUB 100
60 W$ = "SQUAD" : GOSUB 100
70 W$ = "CONFUSE" : GOSUB 100
80 END
90 REM ********************************
100 B$="BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"
110 FOR I=1 TO LEN(W$)
120 BL = LEN(B$)
130 FOR J=1 TO BL STEP 2
140 C$=MID$(B$,J,1): D$=MID$(B$,J+1,1)
150 X$=MID$(W$,I,1)
160 IF C$<>X$ AND D$<>X$ THEN GOTO 190
170 B$ = LEFT$(B$,J-1)+RIGHT$(B$,BL-J-1)
180 GOTO 210
190 NEXT J
200 IF J>BL-1 THEN GOTO 240
210 NEXT I
220 PRINT W$" -> YES"
230 RETURN
240 PRINT W$" -> NO"
250 RETURN

11
Task/ABC-Problem/BASIC/abc-problem-3.basic Normal file
View file

@ -0,0 +1,11 @@
10 LET B$="BOXKDQCPNAGTRETGQDFSJWHUVIANOBERFSLYPCZM"
20 INPUT W$
30 FOR I=1 TO LEN W$
40 FOR J=1 TO LEN B$ STEP 2
50 IF B$(J)<>W$(I) AND B$(J+1)<>W$(I) THEN GOTO 100
60 LET B$=B$( TO J-1)+B$(J+2 TO )
70 NEXT I
80 PRINT "YES"
90 STOP
100 NEXT J
110 PRINT "NO"

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

@ -0,0 +1,24 @@
CONST info$ = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM"
DATA "A", "BARK", "BOOK", "TREAT", "Common", "Squad", "Confuse"
WHILE TRUE
READ word$
IF NOT(LEN(word$)) THEN BREAK
block$ = info$
count = AMOUNT(block$)
FOR y = 1 TO LEN(word$)
FOR x = 1 TO AMOUNT(block$)
IF TALLY(TOKEN$(block$, x), MID$(UCASE$(word$), y, 1)) THEN
block$ = DEL$(block$, x)
BREAK
END IF
NEXT
NEXT
PRINT word$, IIF$(LEN(word$) = count-AMOUNT(block$), "True", "False") FORMAT "%-10s: %s\n"
WEND

2
Task/ABC-Problem/Clojure/abc-problem.clj
View file

@ -10,7 +10,7 @@
(defn abc
"return lazy sequence of solutions (i.e. block lists)"
[blocks [c & cs]]
(if-some c
(if (some? c)
(for [b blocks :when (some #(= c %) b)
bs (abc (omit blocks b) cs)]
(cons b bs))

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

@ -0,0 +1,84 @@
MODULE ABCProblem;
IMPORT
StdLog, DevCommanders, TextMappers;
CONST
notfound = -1;
TYPE
String = ARRAY 3 OF CHAR;
VAR
blocks : ARRAY 20 OF String;
PROCEDURE Check(s: ARRAY OF CHAR): BOOLEAN;
VAR
used: SET;
i,blockIndex: INTEGER;
PROCEDURE GetBlockFor(c: CHAR): INTEGER;
VAR
i: INTEGER;
BEGIN
c := CAP(c);
i := 0;
WHILE (i < LEN(blocks)) DO
IF (c = blocks[i][0]) OR (c = blocks[i][1]) THEN
IF ~(i IN used) THEN RETURN i END
END;
INC(i)
END;
RETURN notfound
END GetBlockFor;
BEGIN
used := {};
FOR i := 0 TO LEN(s$) - 1 DO
blockIndex := GetBlockFor(s[i]);
IF blockIndex = notfound THEN
RETURN FALSE
ELSE
INCL(used,blockIndex)
END
END;
RETURN TRUE
END Check;
PROCEDURE CanMakeWord*;
VAR
s: TextMappers.Scanner;
BEGIN
s.ConnectTo(DevCommanders.par.text);
s.SetPos(DevCommanders.par.beg);
s.Scan;
WHILE (~s.rider.eot) DO
IF (s.type = TextMappers.char) & (s.char = '~') THEN
RETURN
ELSIF (s.type = TextMappers.string) THEN
StdLog.String(s.string);StdLog.String(":> ");
StdLog.Bool(Check(s.string));StdLog.Ln
END;
s.Scan
END
END CanMakeWord;
BEGIN
blocks[0] := "BO";
blocks[1] := "XK";
blocks[2] := "DQ";
blocks[3] := "CP";
blocks[4] := "NA";
blocks[5] := "GT";
blocks[6] := "RE";
blocks[7] := "TG";
blocks[8] := "QD";
blocks[9] := "FS";
blocks[10] := "JW";
blocks[11] := "HU";
blocks[12] := "VI";
blocks[13] := "AN";
blocks[14] := "OB";
blocks[15] := "ER";
blocks[16] := "FS";
blocks[17] := "LY";
blocks[18] := "PC";
blocks[19] := "ZM";
END ABCProblem.

38
Task/ABC-Problem/Elena/abc-problem.elena
View file

@ -1,37 +1,37 @@
#import system.
#import system'routines.
#import system'collections.
#import extensions.
#import extensions'routines.
import system'routines.
import system'collections.
import extensions.
import extensions'routines.
#class(extension)op
extension op
{
#method canMakeWord &from:blocks
canMakeWordFrom:blocks
[
#var list := ArrayList new:blocks.
var list := ArrayList new:blocks.
^ $nil == self literal upperCase seek &each:ch
^ $nil == self literal; upperCase; seekEach(:ch)
[
#var index := list indexOf:(word [ word indexOf:ch &at:0 != -1 ] asComparer).
var index := list indexOfElement
((:word)(word indexOf:ch at:0 != -1) asComparator).
(index>=0)
? [ list remove &at:index. ^ false. ]
! [ ^ true. ].
].
if (index>=0)
[ list remove at:index. ^ false ];
[ ^ true ]
]
]
}
#symbol program =
program =
[
#var blocks := ("BO", "XK", "DQ", "CP", "NA",
var blocks := ("BO", "XK", "DQ", "CP", "NA",
"GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB",
"ER", "FS", "LY", "PC", "ZM").
#var words := ("", "A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "Confuse").
var words := ("", "A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "Confuse").
words run &each:word
words forEach(:word)
[
console writeLine:"can make '":word:"' : ":(word canMakeWord &from:blocks).
console printLine("can make '",word,"' : ",word canMakeWordFrom:blocks).
].
].

4
Task/ABC-Problem/Elixir/abc-problem.elixir
View file

@ -1,12 +1,12 @@
defmodule ABC do
def can_make_word(word, avail) do
can_make_word(String.upcase(word) |> to_char_list, avail, [])
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
(Enum.member?(b,l) and can_make_word(tail, rest++tried, []))
(l in b and can_make_word(tail, rest++tried, []))
or can_make_word([l|tail], rest, [b|tried])
end
end

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

@ -0,0 +1,28 @@
Public Sub Main()
Dim sCheck As String[] = ["A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"]
Dim sBlock As String[] = ["BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS", "JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"]
Dim sList As New String[]
Dim siCount, siLoop As Short
Dim sTemp, sAnswer As String
For Each sTemp In sCheck
sAnswer = ""
sList = sBlock.Copy()
For siCount = 1 To Len(sTemp)
For siLoop = 0 To sList.Max
If InStr(sList[siLoop], Mid(sTemp, siCount, 1)) Then
sList.Extract(siLoop, 1)
sAnswer &= Mid(sTemp, siCount, 1)
Break
Endif
Next
Next
If sAnswer = sTemp Then
Print sTemp & " - True"
Else
Print sTemp & " - False"
End If
Next
End

0
Task/ABC-Problem/Haskell/abc-problem.hs → Task/ABC-Problem/Haskell/abc-problem-1.hs
View file

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

@ -0,0 +1,22 @@
import Data.List (delete)
import Data.Char (toUpper)
-- Any block sequences found
spellWith :: [String] -> String -> [[String]]
spellWith _ [] = [[]]
spellWith blocks (x:xs) =
foldMap
(\b ->
if x `elem` b
then foldMap (return . (b :)) (spellWith (delete b blocks) xs)
else [])
blocks
blocks :: [String]
blocks = words "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM"
main :: IO ()
main =
mapM_
(print . ((,) <*>) (not . null . spellWith blocks . (toUpper <$>)))
["", "A", "BARK", "BoOK", "TrEAT", "COmMoN", "SQUAD", "conFUsE"]

72
Task/ABC-Problem/Java/abc-problem.java
View file

@ -1,44 +1,36 @@
import java.util.Arrays;
import java.util.Collections;
import java.util.List;
public class ABC{
private static void swap(int i, int j, Object... arr){
Object tmp = arr[i];
arr[i] = arr[j];
arr[j] = tmp;
}
public static boolean canMakeWord(String word, String... blocks) {
if(word.length() == 0)
return true;
char c = Character.toUpperCase(word.charAt(0));
for(int i = 0; i < blocks.length; i++) {
String b = blocks[i];
if(Character.toUpperCase(b.charAt(0)) != c && Character.toUpperCase(b.charAt(1)) != c)
continue;
swap(0, i, blocks);
if(canMakeWord(word.substring(1), Arrays.copyOfRange(blocks, 1, blocks.length)))
return true;
swap(0, i, blocks);
}
return false;
}
public static void main(String[] args){
String[] blocks = {"BO", "XK", "DQ", "CP", "NA",
"GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB",
"ER", "FS", "LY", "PC", "ZM"};
public class ABC {
System.out.println("\"\": " + canMakeWord("", blocks));
System.out.println("A: " + canMakeWord("A", blocks));
System.out.println("BARK: " + canMakeWord("BARK", blocks));
System.out.println("book: " + canMakeWord("book", blocks));
System.out.println("treat: " + canMakeWord("treat", blocks));
System.out.println("COMMON: " + canMakeWord("COMMON", blocks));
System.out.println("SQuAd: " + canMakeWord("SQuAd", blocks));
System.out.println("CONFUSE: " + canMakeWord("CONFUSE", blocks));
}
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;
}
}

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

@ -0,0 +1,97 @@
(() => {
'use strict';
// ABC BLOCKS -------------------------------------------------------------
// spellWith :: [(Char, Char)] -> [Char] -> [[(Char, Char)]]
const spellWith = (blocks, wordChars) =>
(isNull(wordChars)) ? [
[]
] :
(() => {
const [x, xs] = uncons(wordChars);
return concatMap(
b => elem(x, b) ? concatMap(
bs => [cons(b, bs)],
spellWith(
deleteBy(
(p, q) => (p[0] === q[0]) && (p[1] === q[1]),
b, blocks
),
xs
)
) : [],
blocks
);
})();
// GENERIC FUNCTIONS ------------------------------------------------------
// compose :: [(a -> a)] -> (a -> a)
const compose = fs => x => fs.reduceRight((a, f) => f(a), x);
// concatMap :: (a -> [b]) -> [a] -> [b]
const concatMap = (f, xs) => [].concat.apply([], xs.map(f));
// cons :: a -> [a] -> [a]
const cons = (x, xs) => [x].concat(xs);
// curry :: Function -> Function
const curry = (f, ...args) => {
const go = xs => xs.length >= f.length ? (f.apply(null, xs)) :
function () {
return go(xs.concat([].slice.apply(arguments)));
};
return go([].slice.call(args, 1));
};
// deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]
const deleteBy = (f, x, xs) =>
xs.length > 0 ? (
f(x, xs[0]) ? (
xs.slice(1)
) : [xs[0]].concat(deleteBy(f, x, xs.slice(1)))
) : [];
// elem :: Eq a => a -> [a] -> Bool
const elem = (x, xs) => xs.indexOf(x) !== -1;
// isNull :: [a] -> Bool
const isNull = xs => (xs instanceof Array) ? xs.length < 1 : undefined;
// map :: (a -> b) -> [a] -> [b]
const map = (f, xs) => xs.map(f);
// not :: Bool -> Bool
const not = b => !b;
// show :: a -> String
const show = x => JSON.stringify(x); //, null, 2);
// stringChars :: String -> [Char]
const stringChars = s => s.split('');
// toUpper :: Text -> Text
const toUpper = s => s.toUpperCase();
// uncons :: [a] -> Maybe (a, [a])
const uncons = xs => xs.length ? [xs[0], xs.slice(1)] : undefined;
// unlines :: [String] -> String
const unlines = xs => xs.join('\n');
// words :: String -> [String]
const words = s => s.split(/\s+/);
// TEST -------------------------------------------------------------------
// blocks :: [(Char, Char)]
const blocks = words(
"BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM"
);
return unlines(map(
x => show([x, compose(
[not, isNull, curry(spellWith)(blocks), stringChars, toUpper]
)(x)]), ["", "A", "BARK", "BoOK", "TrEAT", "COmMoN", "SQUAD", "conFUsE"]
));
})();

0
Task/ABC-Problem/jq/abc-problem-1.jq → Task/ABC-Problem/Jq/abc-problem-1.jq
View file

0
Task/ABC-Problem/jq/abc-problem-2.jq → Task/ABC-Problem/Jq/abc-problem-2.jq
View file

4
Task/ABC-Problem/Kotlin/abc-problem.kotlin
View file

@ -1,5 +1,3 @@
package abc
object ABC_block_checker {
fun run() {
val blocks = arrayOf("BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS",
@ -17,7 +15,7 @@ object ABC_block_checker {
}
private fun Array<String>.canMakeWord(word: String): Boolean {
if (word.length == 0)
if (word.isEmpty())
return true
val c = Character.toUpperCase(word.first())

35
Task/ABC-Problem/Nim/abc-problem.nim
View file

@ -1,33 +1,24 @@
from strutils import contains, format, toUpper
from strutils import toUpperAscii, contains, format
from sequtils import delete
proc canMakeWord(s: string): bool =
proc makeWord(s: string): bool =
var
abcs = @["BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"]
matched = newSeq[string]()
if s.len > abcs.len:
return false
for i in 0 .. s.len - 1:
var
letter = s[i].toUpper
n = 0
for abc in abcs:
if contains(abc, letter):
delete(abcs, n, n)
matched = matched & abc
break
else:
inc(n)
for ch in s.toUpperAscii.items:
block outer:
for i, abc in abcs.pairs:
if abc.contains(ch):
abcs.delete(i)
break outer
return false
return true
if matched.len == s.len:
return true
else:
return false
var words = @["A", "bArK", "BOOK", "treat", "common", "sQuAd", "CONFUSE"]
let words = @["A", "bArK", "BOOK", "treat", "common", "sQuAd", "CONFUSE"]
for word in words:
echo format("Can the blocks make the word \"$1\"? $2", word,
(if canMakeWord(word): "yes" else: "no"))
echo format("""Can the blocks make the word "$1"? $2 """, word,
if makeWord(word): "yes" else: "no")

3
Task/ABC-Problem/PL-I/abc-problem-1.pli
View file

@ -11,7 +11,8 @@ ABC: procedure options (main); /* 12 January 2014 */
do word = 'A', 'BARK', 'BOOK', 'TREAT', 'COMMON', 'SQuAd', 'CONFUSE';
flag = true;
tblocks = blocks;
do i = 1 to length(word);
do i = 1 to length(word)
while(flag = true);
ch = substr(word, i, 1);
k = index(tblocks, uppercase(ch));
if k = 0 then

6
Task/ABC-Problem/PureBasic/abc-problem-1.purebasic
View file

@ -2,9 +2,9 @@ EnableExplicit
#LETTERS = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM "
Procedure.s can_make_word(word.s)
Define.s letters = #LETTERS, buffer
Define.i index1, index2
Define.b match
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

1
Task/ABC-Problem/PureBasic/abc-problem-2.purebasic
View file

@ -1,4 +1,3 @@
Define.i
#LETTERS = "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM "
Macro test(t)

5
Task/ABC-Problem/Python/abc-problem-1.py
View file

@ -1,3 +1,8 @@
'''
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"),

45
Task/ABC-Problem/REXX/abc-problem-1.rexx
View file

@ -1,24 +1,21 @@
/*REXX program determines if words can be spelt from a pool of toy blocks. */
list= 'A bark bOOk treat common squaD conFuse' /*words can be in any case. */
blocks= 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM'
do k=1 for words(list) /*traipse through a list of seven words*/
call spell word(list,k) /*display if word can be spelt (or not)*/
end /*k*/ /* [↑] tests each word in the list. */
exit /*stick a fork in it, we're all done. */
/*────────────────────────────────────────────────────────────────────────────*/
spell: procedure expose blocks; arg x; p.=0 /*uppercase word to be spelt. */
parse upper var blocks theBlocks; L=length(x) /*uppercase the block letters.*/
/* [↓] try to spell the word.*/
do try=1 for L; z=theBlocks /*use a fresh copy of Z blocks*/
do n=1 for L; y=substr(x,n,1) /*attempt another block letter*/
p.n=pos(y,z,1+p.n); if p.n==0 then iterate try /*not found? Try again.*/
z=overlay(' ',z,p.n) /*mutate block ───► a onesy.*/
do k=1 for words(blocks) /*scrub block pool (not 1s). */
if length(word(z,k))==1 then z=delword(z,k,1) /*single char? Delete.*/
end /*k*/ /* [↑] elide any onesy block.*/
if n==L then leave try /*was the last letter spelt? */
end /*n*/ /* [↑] end of a block attempt*/
end /*try*/ /* [↑] end of "TRY" permute. */
say right(arg(1),30) right(word("can't can", (n==L)+1), 6) 'be spelt.'
return
/*REXX pgm finds if words can be spelt from a pool of toy blocks (each having 2 letters)*/
list= 'A bark bOOk treat common squaD conFuse' /*words can be: upper/lower/mixed case*/
blocks= 'BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM'
do k=1 for words(list) /*traipse through a list of some words.*/
call spell word(list, k) /*display if word can be spelt (or not)*/
end /*k*/ /* [↑] tests each word in the list. */
exit /*stick a fork in it, we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
spell: procedure expose blocks; arg x /*ARG uppercases the word to be spelt.*/
L=length(x); @.=0 /*get length of the word to be spelt. */
do try=1 for L; z=blocks; upper z /*use a fresh copy of the "Z" blocks.*/
do n=1 for L; y=substr(x, n, 1) /*attempt another letter in the word. */
@.n=pos(y, z, 1 + @.n); if @.n==0 then leave /*not found? Try again*/
z=overlay(' ', z, @.n) /*mutate the toy block ───► a onesy. */
do q=1 for words(z); if length(word(z, q))==1 then z=delword(z, q, 1)
end /*q*/ /* [↑] elide any existing onesy block.*/
if n==L then leave try /*was last letter used in the spelling?*/
end /*n*/ /* [↑] end of a toy block usage. */
end /*try*/ /* [↑] end of a "TRY" permute. */
say right(arg(1), 30) right( word( "can't can", (n==L) +1), 6) 'be spelt.'
return

96
Task/ABC-Problem/Simula/abc-problem.simula Normal file
View file

@ -0,0 +1,96 @@
COMMENT ABC PROBLEM;
BEGIN
CLASS BLOCK(CH1, CH2); CHARACTER CH1, CH2;
BEGIN
BOOLEAN USED;
END;
CLASS GAME(WORD, POSSIBLE); TEXT WORD; BOOLEAN POSSIBLE;;
BOOLEAN PROCEDURE CANMAKEWORD(WORD); TEXT WORD;
BEGIN
INTEGER I, NUMBLOCKS;
BOOLEAN ALLPOSSIBLE, FOUND;
NUMBLOCKS := UPPERBOUND(BLOCKS, 1);
FOR I := 1 STEP 1 UNTIL NUMBLOCKS DO
BLOCKS(I).USED := FALSE;
ALLPOSSIBLE := TRUE;
WORD.SETPOS(1);
WHILE ALLPOSSIBLE AND WORD.MORE DO
BEGIN
CHARACTER WORDCHAR;
WORDCHAR := WORD.GETCHAR;
FOUND := FALSE;
FOR I := 1 STEP 1 UNTIL NUMBLOCKS DO
BEGIN
INSPECT BLOCKS(I) DO
BEGIN
IF (WORDCHAR = CH1 OR WORDCHAR = CH2) AND NOT USED THEN
BEGIN
USED := FOUND := TRUE;
GOTO L;
END;
END;
END;
L:
IF NOT FOUND THEN
ALLPOSSIBLE := FALSE;
END;
CANMAKEWORD := ALLPOSSIBLE;
END CANMAKEWORD;
REF(BLOCK) ARRAY BLOCKS(1:20);
REF(GAME) ARRAY GAMES(1:7);
TEXT WORD;
BEGIN
INTEGER I;
I := I+1; BLOCKS(I) :- NEW BLOCK('B', 'O');
I := I+1; BLOCKS(I) :- NEW BLOCK('X', 'K');
I := I+1; BLOCKS(I) :- NEW BLOCK('D', 'Q');
I := I+1; BLOCKS(I) :- NEW BLOCK('C', 'P');
I := I+1; BLOCKS(I) :- NEW BLOCK('N', 'A');
I := I+1; BLOCKS(I) :- NEW BLOCK('G', 'T');
I := I+1; BLOCKS(I) :- NEW BLOCK('R', 'E');
I := I+1; BLOCKS(I) :- NEW BLOCK('T', 'G');
I := I+1; BLOCKS(I) :- NEW BLOCK('Q', 'D');
I := I+1; BLOCKS(I) :- NEW BLOCK('F', 'S');
I := I+1; BLOCKS(I) :- NEW BLOCK('J', 'W');
I := I+1; BLOCKS(I) :- NEW BLOCK('H', 'U');
I := I+1; BLOCKS(I) :- NEW BLOCK('V', 'I');
I := I+1; BLOCKS(I) :- NEW BLOCK('A', 'N');
I := I+1; BLOCKS(I) :- NEW BLOCK('O', 'B');
I := I+1; BLOCKS(I) :- NEW BLOCK('E', 'R');
I := I+1; BLOCKS(I) :- NEW BLOCK('F', 'S');
I := I+1; BLOCKS(I) :- NEW BLOCK('L', 'Y');
I := I+1; BLOCKS(I) :- NEW BLOCK('P', 'C');
I := I+1; BLOCKS(I) :- NEW BLOCK('Z', 'M');
END;
BEGIN
INTEGER N, I; BOOLEAN ANSWER;
N := N+1; GAMES(N) :- NEW GAME("A", TRUE);
N := N+1; GAMES(N) :- NEW GAME("BARK", TRUE);
N := N+1; GAMES(N) :- NEW GAME("BOOK", FALSE);
N := N+1; GAMES(N) :- NEW GAME("TREAT", TRUE);
N := N+1; GAMES(N) :- NEW GAME("COMMON", FALSE);
N := N+1; GAMES(N) :- NEW GAME("SQUAD", TRUE);
N := N+1; GAMES(N) :- NEW GAME("CONFUSE", TRUE);
FOR I := 1 STEP 1 UNTIL N DO
BEGIN
INSPECT GAMES(I) DO
BEGIN
OUTTEXT(WORD);
OUTTEXT(" => ");
ANSWER := CANMAKEWORD(WORD);
OUTCHAR(IF ANSWER THEN 'T' ELSE 'F');
IF ANSWER EQV POSSIBLE
THEN OUTTEXT(" OK")
ELSE OUTTEXT(" ------------- WRONG!");
OUTIMAGE;
END;
END;
END;
END.

0
Task/ABC-Problem/Swift/abc-problem.swift → Task/ABC-Problem/Swift/abc-problem-1.swift
View file

22
Task/ABC-Problem/Swift/abc-problem-2.swift Normal file
View file

@ -0,0 +1,22 @@
import Swift
func canMake(word: String) -> Bool {
var blocks = [
"BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM"
]
for letter in word.uppercased().characters {
guard let index = blocks.index(where: { $0.characters.contains(letter) }) else {
return false
}
blocks.remove(at: index)
}
return true
}
let words = ["a", "bARK", "boOK", "TreAt", "CoMmon", "SquAd", "CONFUse"]
words.forEach { print($0, canMake(word: $0)) }

19
Task/ABC-Problem/Zkl/abc-problem.zkl Normal file
View file

@ -0,0 +1,19 @@
var blocks=T("BO", "XK", "DQ", "CP", "NA", "GT", "RE", "TG", "QD", "FS",
"JW", "HU", "VI", "AN", "OB", "ER", "FS", "LY", "PC", "ZM", );
fcn can_make_word(word){
fcn(blks,word){
if (not word) return(True); // bottom of recursion
foreach b in (blks){ n:=__bWalker.idx;
if(not b.holds(word[0])) continue; // letter not on this block
blks.del(n); // remove this block from pile
if (self.fcn(blks,word[1,*])) return(True); // try remaining blocks
blks.insert(n,b); // put block back in pile: backtracking
}
False; // out of blocks but not out of word
}(blocks.copy(),word.toUpper())
}
foreach word in (T("","A","BarK","BOOK","TREAT","COMMON","SQUAD","Confuse","abba")){
can_make_word(word).println(": ",word);
}