September Morn Update

Task/ABC-Problem/00META.yaml

@@ -0,0 +1,4 @@
+---
+category:
+- Puzzles
+- Games

Task/ABC-Problem/Astro/abc-problem.astro

@@ -1,13 +1,12 @@
-fun abc(str, list):
-    if list.isempty:
+fun abc(s, ls):
+    if ls.isempty:
         return true
     for i in indices(list) where s[end] in list[i]:
-        return abc(str[end-1:], remove(val list, i))
+        return abc(s[:end-1], remove!(copy(list), at: i))
     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"]
+let ls = ["BO","XK","DQ","CP","NA","GT","RE","TG","QD","FS", "JW","HU","VI","AN","OB","ER","FS","LY","PC","ZM"]
 
-for str in test:
-    print "$|>8|{s} | ${abc(s, list)}"
+for s in test:
+    print "($|>8|{s} ${abc(s, list)})"

Task/ABC-Problem/Elena/abc-problem.elena

@@ -1,37 +1,45 @@
-import system'routines.
-import system'collections.
-import extensions.
-import extensions'routines.
+import system'routines;
+import system'collections;
+import extensions;
+import extensions'routines;
 
 extension op
 {
-    canMakeWordFrom:blocks
-    [
-        var list := ArrayList new:blocks.
+    canMakeWordFrom(blocks)
+    {
+        var list := ArrayList.load(blocks);
 
-        ^ nil == self literal; upperCase; seekEach(:ch)
-        [
-            var index := list indexOfElement
-                ((:word)(word indexOf:ch at:0 != -1) asComparator).
+        ^ 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 ];
-                [ ^ true ]
-        ]
-    ]
+            {
+                list.removeAt(index); ^ false
+            }
+            else
+            {
+                ^ true
+            }
+        }
+    }
 }
 
-public program
-[
-    var blocks := ("BO", "XK", "DQ", "CP", "NA",
+public program()
+{
+    var blocks := new object[] {"BO", "XK", "DQ", "CP", "NA",
 		"GT", "RE", "TG", "QD", "FS",
 		"JW", "HU", "VI", "AN", "OB",
-		"ER", "FS", "LY", "PC", "ZM").
+		"ER", "FS", "LY", "PC", "ZM"};
 
-    var words := ("", "A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "Confuse").
+    var words := new object[] {"", "A", "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "Confuse"};
 
-    words forEach(:word)
-    [
-        console printLine("can make '",word,"' : ",word canMakeWordFrom:blocks).
-    ]
-]
+    Enumerator e := words.enumerator();
+    e.next();
+
+    words.forEach:(word)
+    {
+        console.printLine("can make '",word,"' : ",word.canMakeWordFrom(blocks));
+    }
+}

Task/ABC-Problem/Factor/abc-problem.factor

@@ -0,0 +1,45 @@
+USING: assocs combinators.short-circuit formatting grouping io
+kernel math math.statistics qw sequences sets unicode ;
+IN: rosetta-code.abc-problem
+
+! === CONSTANTS ================================================
+
+CONSTANT: blocks qw{
+    BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM
+}
+
+CONSTANT: input qw{ A BARK BOOK TREAT COMMON SQUAD CONFUSE }
+
+! === PROGRAM LOGIC ============================================
+
+: pare ( str -- seq )
+    [ blocks ] dip [ intersects? ] curry filter ;
+
+: enough-blocks? ( str -- ? ) dup pare [ length ] bi@ <= ;
+
+: enough-letters? ( str -- ? )
+    [ blocks concat ] dip dup [ within ] dip
+    [ histogram values ] bi@ [ - ] 2map [ neg? ] any? not ;
+
+: can-make-word? ( str -- ? )
+    >upper { [ enough-blocks? ] [ enough-letters? ] } 1&& ;
+
+! === OUTPUT ===================================================
+
+: show-blocks ( -- )
+    "Available blocks:" print blocks [ 1 cut "(%s %s)" sprintf ]
+    map 5 group [ [ write bl ] each nl ] each nl ;
+
+: header ( -- )
+    "Word" "Can make word from blocks?" "%-7s %s\n" printf
+    "======= ==========================" print ;
+
+: result ( str -- )
+    dup can-make-word? "Yes" "No" ? "%-7s %s\n" printf ;
+
+! === MAIN =====================================================
+
+: abc-problem ( -- )
+    show-blocks header input [ result ] each ;
+
+MAIN: abc-problem

Task/ABC-Problem/FreeBASIC/abc-problem.freebasic

@@ -0,0 +1,43 @@
+' version 28-01-2019
+' compile with: fbc -s console
+
+Dim As String blocks(1 To 20, 1 To 2) => {{"B", "O"}, {"X", "K"}, {"D", "Q"}, _
+{"C", "P"}, {"N", "A"}, {"G", "T"}, {"R", "E"}, {"T", "G"}, {"Q", "D"}, _
+{"F", "S"}, {"J", "W"}, {"H", "U"}, {"V", "I"}, {"A", "N"}, {"O", "B"}, _
+{"E", "R"}, {"F", "S"}, {"L", "Y"}, {"P", "C"}, {"Z", "M"}}
+
+Dim As UInteger i, x, y, b()
+Dim As String word, char
+Dim As boolean possible
+
+Do
+    Read word
+    If word = "" Then Exit Do
+    word = UCase(word)
+    ReDim b(1 To 20)
+    possible = TRUE
+
+    For i = 1 To Len(word)
+        char = Mid(word, i, 1)
+
+        For x = 1 To 20
+            If b(x) = 0 Then
+                If blocks(x, 1) = char Or blocks(x, 2) = char Then
+                    b(x) = 1
+                    Exit For
+                End If
+            End If
+        Next
+        If x = 21 Then possible = FALSE
+    Next
+
+    Print word, possible
+Loop
+
+Data  "A", "Bark", "Book", "Treat", "Common", "Squad", "Confuse", ""
+
+' empty keyboard buffer
+While InKey <> "" : Wend
+Print : Print "hit any key to end program"
+Sleep
+End

Task/ABC-Problem/Haskell/abc-problem-2.hs

@@ -1,16 +1,13 @@
 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
+  let go b
+        | x `elem` b = (b :) <$> spellWith (delete b blocks) xs
+        | otherwise = []
+  in blocks >>= go
 
 blocks :: [String]
 blocks = words "BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM"
@@ -18,5 +15,5 @@ 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 <$>)))
+    (print . ((,) <*>) (not . null . spellWith blocks . fmap toUpper))
     ["", "A", "BARK", "BoOK", "TrEAT", "COmMoN", "SQUAD", "conFUsE"]

Task/ABC-Problem/Mercury/abc-problem.mercury

@@ -0,0 +1,34 @@
+:- 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).