Word ladder: Difference between revisions
Not a robot (talk | contribs) Add APL |
|||
(24 intermediate revisions by 12 users not shown) | |||
Line 2:
Yet another shortest path problem. Given two words of equal length the task is to transpose the first into the second.
Only one letter may be changed at a time and the change must result in a word in [http://wiki.puzzlers.org/pub/wordlists/unixdict.txt unixdict], the minimum number of intermediate words should be used.
Demonstrate the following:
Line 10:
With a little more difficulty a girl can be made into a lady: girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady
A child can not be turned into an adult.
Line 20:
<br><br>
=={{header|11l}}==
{{trans|Nim}}
<syntaxhighlight lang="11l">F isOneAway(word1, word2)
V result = 0B
L(i) 0 .< word1.len
I word1[i] != word2[i]
I result
R 0B
E
result = 1B
R result
DefaultDict[Int, [String]] words
L(word) File(‘unixdict.txt’).read().split("\n")
words[word.len] [+]= word
F find_path(start, target)
V lg = start.len
assert(target.len == lg, ‘Source and destination must have same length.’)
assert(start C :words[lg], ‘Source must exist in the dictionary.’)
assert(target C :words[lg], ‘Destination must exist in the dictionary.’)
V currPaths = [[start]]
V pool = copy(:words[lg])
L
[[String]] newPaths
[String] added
L(candidate) pool
L(path) currPaths
I isOneAway(candidate, path.last)
V newPath = path [+] [candidate]
I candidate == target
R newPath
E
newPaths.append(newPath)
added.append(candidate)
L.break
I newPaths.empty
L.break
currPaths = move(newPaths)
L(w) added
pool.remove(w)
R [String]()
L(start, target) [(‘boy’, ‘man’), (‘girl’, ‘lady’), (‘john’, ‘jane’), (‘child’, ‘adult’), (‘cat’, ‘dog’), (‘lead’, ‘gold’), (‘white’, ‘black’), (‘bubble’, ‘tickle’)]
V path = find_path(start, target)
I path.empty
print(‘No path from "’start‘" to "’target‘".’)
E
print(path.join(‘ -> ’))</syntaxhighlight>
{{out}}
<pre>
boy -> bay -> ban -> man
girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady
john -> cohn -> conn -> cone -> cane -> jane
No path from "child" to "adult".
cat -> cot -> cog -> dog
lead -> load -> goad -> gold
white -> whine -> chine -> chink -> clink -> blink -> blank -> black
bubble -> babble -> gabble -> garble -> gargle -> gaggle -> giggle -> jiggle -> jingle -> tingle -> tinkle -> tickle
</pre>
=={{header|Ada}}==
Changed my solution to use Multiway_Trees.
<syntaxhighlight lang="ada">
pragma Ada_2022;
with Ada.Containers.Multiway_Trees;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Text_IO.Unbounded_IO; use Ada.Text_IO.Unbounded_IO;
procedure Word_Ladder is
DICT_FILENAME : constant String := "unixdict.txt";
MAX_DEPTH : constant Positive := 50;
subtype LC_Chars is Character range 'a' .. 'z';
type Word_Node_T is record
Level : Positive;
Word : Unbounded_String;
end record;
package Word_Vectors is new Ada.Containers.Vectors (Positive, Unbounded_String);
package Dict_Vectors is new Ada.Containers.Vectors (Positive, Unbounded_String);
package Word_Trees is new Ada.Containers.Multiway_Trees (Word_Node_T);
use Word_Trees;
Word_Tree : Tree;
Solved : Boolean;
Solution : Cursor;
function Load_Candidate_Words (Dict_Filename : String; Word_Len : Positive)
return Dict_Vectors.Vector is
Dict_File : File_Type;
Read_Word : Unbounded_String;
Cands : Dict_Vectors.Vector;
Valid : Boolean;
C : Character;
begin
Open (File => Dict_File, Mode => In_File, Name => Dict_Filename);
while not End_Of_File (Dict_File) loop
Read_Word := Get_Line (Dict_File);
if Length (Read_Word) = Word_Len then
Valid := True;
for Ix in 1 .. Word_Len loop
C := Element (Read_Word, Ix);
Valid := C in LC_Chars;
exit when not Valid;
end loop;
if Valid then Cands.Append (Read_Word); end if;
end if;
end loop;
Close (Dict_File);
return Cands;
end Load_Candidate_Words;
function Mutate (Word : Unbounded_String; Dict : in out Dict_Vectors.Vector)
return Word_Vectors.Vector is
Mutations : Word_Vectors.Vector;
Poss_Word : Unbounded_String;
begin
for Ix in 1 .. Length (Word) loop
for Letter in LC_Chars loop
if Letter /= Element (Word, Ix) then
Poss_Word := Word;
Replace_Element (Poss_Word, Ix, Letter);
if Dict.Contains (Poss_Word) then
Mutations.Append (Poss_Word);
Dict.Delete (Dict.Find_Index (Poss_Word));
end if;
end if;
end loop;
end loop;
return Mutations;
end Mutate;
procedure Recurse_Tree (Start_Pos : Cursor;
Level : Positive;
Target : Unbounded_String;
Dict : in out Dict_Vectors.Vector) is
Pos : Cursor := Start_Pos;
Mutations : Word_Vectors.Vector;
New_Node : Word_Node_T;
begin
while not Solved and then Pos /= No_Element loop
if Element (Pos).Level = Level then
Mutations := Mutate (Element (Pos).Word, Dict);
if not Word_Vectors.Is_Empty (Mutations) then
for Word of Mutations loop
New_Node.Level := Level + 1;
New_Node.Word := Word;
Append_Child (Word_Tree, Pos, New_Node);
if Word = Target then
Solved := True;
Solution := Pos;
end if;
end loop;
end if;
end if;
if not Solved then
Recurse_Tree (First_Child (Pos), Level, Target, Dict);
end if;
Pos := Next_Sibling (Pos);
end loop;
end Recurse_Tree;
procedure Ladder (Start_S, Target_S : String) is
Dictionary : Dict_Vectors.Vector;
Level : Positive := 1;
Word_Node : Word_Node_T;
Start, Target : Unbounded_String;
Start_Pos : Cursor;
Output : Unbounded_String;
begin
if Start_S'Length /= Target_S'Length then
Put_Line ("ERROR: Start and Target words must be same length.");
return;
end if;
Dictionary := Load_Candidate_Words (DICT_FILENAME, Start_S'Length);
Start := To_Unbounded_String (Start_S);
Target := To_Unbounded_String (Target_S);
Solved := False;
Word_Node.Level := 1;
Word_Node.Word := Start;
Word_Tree := Empty_Tree;
Word_Tree.Insert_Child (Word_Tree.Root, No_Element, Word_Node);
Start_Pos := Find (Word_Tree, Word_Node);
while Level <= MAX_DEPTH and then not Solved loop
Recurse_Tree (Start_Pos, Level, Target, Dictionary);
Level := @ + 1;
end loop;
if not Solved then
Put_Line (Start & " -> " & Target & " - No solution found at depth" & MAX_DEPTH'Image);
else
while not Is_Root (Solution) loop
Word_Node := Element (Solution);
Output := Word_Node.Word & " -> " & Output;
Solution := Parent (Solution);
end loop;
Put_Line (Output & Target);
end if;
end Ladder;
begin
Ladder ("boy", "man");
Ladder ("girl", "lady");
Ladder ("jane", "john");
Ladder ("child", "adult");
Ladder ("ada", "god");
Ladder ("rust", "hell");
end Word_Ladder;
</syntaxhighlight>
{{out}}
As expected "ada" can become a "god", and "rust" can go to "hell" :-)
<pre>
boy -> bay -> may -> man
girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady
jane -> cane -> cone -> conn -> cohn -> john
child -> adult - No solution found at depth 50
ada -> fda -> faa -> fad -> gad -> god
rust -> bust -> best -> belt -> bell -> hell
</pre>
=={{header|ALGOL 68}}==
With ''a68g'' use option <code>--storage 2</code>, otherwise it runs out of memory.
<syntaxhighlight lang="algol68"># quick implementation of a stack of INT.
real program starts after it.
#
MODE STACK = STRUCT (INT top, FLEX[1:0]INT data, INT increment);
PROC makestack = (INT increment)STACK: (1, (), increment);
PROC pop = (REF STACK s)INT: ( top OF s -:= 1; (data OF s)[top OF s] );
PROC push = (REF STACK s, INT n)VOID:
BEGIN
IF top OF s > UPB data OF s THEN
[ UPB data OF s + increment OF s ]INT tmp;
tmp[1 : UPB data OF s] := data OF s;
data OF s := tmp
FI;
(data OF s)[top OF s] := n;
top OF s +:= 1
END;
PROC empty = (REF STACK s)BOOL: top OF s <= 1;
PROC contents = (REF STACK s)[]INT: (data OF s)[:top OF s - 1];
# start solution #
[]STRING words = BEGIN # load dictionary file into array #
FILE f;
BOOL eof := FALSE;
open(f, "unixdict.txt", stand in channel);
on logical file end(f, (REF FILE f)BOOL: eof := TRUE);
INT idx := 1;
FLEX [1:0] STRING words;
STRING word;
WHILE NOT eof DO
get(f, (word, newline));
IF idx > UPB words THEN
HEAP [1 : UPB words + 10000]STRING tmp;
tmp[1 : UPB words] := words;
words := tmp
FI;
words[idx] := word;
idx +:= 1
OD;
words[1:idx-1]
END;
INT nwords = UPB words;
INT max word length = (INT mwl := 0;
FOR i TO UPB words DO
IF mwl < UPB words[i] THEN mwl := UPB words[i] FI
OD;
mwl);
[nwords]FLEX[0]INT neighbors;
[max word length]BOOL precalculated by length;
FOR i TO UPB precalculated by length DO precalculated by length[i] := FALSE OD;
# precalculating neighbours takes time, but not doing it is even slower... #
PROC precalculate neighbors = (INT word length)VOID:
BEGIN
[nwords]REF STACK stacks;
FOR i TO UPB stacks DO stacks[i] := NIL OD;
FOR i TO UPB words DO
IF UPB words[i] = word length THEN
IF REF STACK(stacks[i]) :=: NIL THEN stacks[i] := HEAP STACK := makestack(10) FI;
FOR j FROM i + 1 TO UPB words DO
IF UPB words[j] = word length THEN
IF neighboring(words[i], words[j]) THEN
push(stacks[i], j);
IF REF STACK(stacks[j]) :=: NIL THEN stacks[j] := HEAP STACK := makestack(10) FI;
push(stacks[j], i)
FI
FI
OD
FI
OD;
FOR i TO UPB neighbors DO
IF REF STACK(stacks[i]) :/=: NIL THEN
neighbors[i] := contents(stacks[i])
FI
OD;
precalculated by length [word length] := TRUE
END;
PROC neighboring = (STRING a, b)BOOL: # do a & b differ in just 1 char? #
BEGIN
INT diff := 0;
FOR i TO UPB a DO IF a[i] /= b[i] THEN diff +:= 1 FI OD;
diff = 1
END;
PROC word ladder = (STRING from, STRING to)[]STRING:
BEGIN
IF UPB from /= UPB to THEN fail FI;
INT word length = UPB from;
IF word length < 1 OR word length > max word length THEN fail FI;
IF from = to THEN fail FI;
INT start := 0;
INT destination := 0;
FOR i TO UPB words DO
IF UPB words[i] = word length THEN
IF words[i] = from THEN start := i
ELIF words[i] = to THEN destination := i
FI
FI
OD;
IF destination = 0 OR start = 0 THEN fail FI;
IF NOT precalculated by length [word length] THEN
precalculate neighbors(word length)
FI;
STACK stack := makestack(1000);
[nwords]INT distance;
[nwords]INT previous;
FOR i TO nwords DO distance[i] := nwords+1; previous[i] := 0 OD;
INT shortest := nwords+1;
distance[start] := 0;
push(stack, start);
WHILE NOT empty(stack)
DO
INT curr := pop(stack);
INT dist := distance[curr];
IF dist < shortest - 1 THEN
# find neighbors and add them to the stack #
FOR i FROM UPB neighbors[curr] BY -1 TO 1 DO
INT n = neighbors[curr][i];
IF distance[n] > dist + 1 THEN
distance[n] := dist + 1;
previous[n] := curr;
IF n = destination THEN
shortest := dist + 1
ELSE
push(stack, n)
FI
FI
OD;
IF curr = destination THEN shortest := dist FI
FI
OD;
INT length = distance[destination] + 1;
IF length > nwords THEN fail FI;
[length]STRING result;
INT curr := destination;
FOR i FROM length BY -1 TO 1
DO
result[i] := words[curr];
curr := previous[curr]
OD;
result EXIT
fail: LOC [0] STRING
END;
[][]STRING pairs = (("boy", "man"), ("bed", "cot"),
("old", "new"), ("dry", "wet"),
("girl", "lady"), ("john", "jane"),
("lead", "gold"), ("poor", "rich"),
("lamb", "stew"), ("kick", "goal"),
("cold", "warm"), ("nude", "clad"),
("child", "adult"), ("white", "black"),
("bread", "toast"), ("lager", "stout"),
("bride", "groom"), ("table", "chair"),
("bubble", "tickle"));
FOR i TO UPB pairs
DO
STRING from = pairs[i][1], to = pairs[i][2];
[]STRING ladder = word ladder(from, to);
IF UPB ladder = 0
THEN print(("No solution for """ + from + """ -> """ + to + """", newline))
ELSE FOR j TO UPB ladder DO print(((j > 1 | "->" | ""), ladder[j])) OD;
print(newline)
FI
OD</syntaxhighlight>
{{out}}
<pre>boy->bay->ban->man
bed->bad->bat->cat->cot
old->odd->ode->one->nne->nee->new
dry->dey->bey->bet->wet
girl->gill->gall->gale->gaze->laze->lazy->lady
john->cohn->conn->cone->cane->jane
lead->load->goad->gold
poor->boor->book->bock->rock->rick->rich
lamb->lame->laue->laud->saud->spud->sped->spew->stew
kick->dick->dock->cock->cook->cool->coal->goal
cold->cord->card->ward->warm
nude->node->bode->bole->bold->gold->goad->glad->clad
No solution for "child" -> "adult"
white->whine->chine->chink->clink->blink->blank->black
bread->break->bleak->bleat->blest->blast->boast->toast
lager->hager->hagen->haven->raven->ravel->navel->novel->hovel->hotel->motel->monel->money->honey->haney->handy->dandy->danny->denny->penny->peony->phony->phone->shone->shore->short->shout->stout
bride->brice->brick->brock->brook->broom->groom
No solution for "table" -> "chair"
bubble->babble->gabble->garble->gargle->gaggle->giggle->jiggle->jingle->tingle->tinkle->tickle</pre>
=={{header|APL}}==
{{works with|Dyalog APL}}
<syntaxhighlight lang="apl">wordladder←{
from to←⍵
dict←((≢¨⍺)=≢to)/⍺
dict{
match←(⊂to)≡¨⊃∘⌽¨⍵
∨/match:⊃match/⍵
0∊≢¨⍺⍵:⍬
word←⊃⌽ladder←⊃⍵
next←(1=⍺+.≠¨⊂word)/⍺
(⍺~next)∇(1↓⍵),(⊂ladder),¨⊂¨next
}⊂⊂from
}
task←{
dict←(~dict∊⎕TC)⊆dict←⊃⎕NGET'unixdict.txt'
pairs←('boy' 'man')('girl' 'lady')('john' 'jane')('child' 'adult')
⎕←↑↑{
hdr←⍺,' → ',⍵,': '
ladder←dict wordladder ⍺ ⍵
0=≢ladder:hdr,'impossible'
hdr,1↓∊'→',¨ladder
}/¨pairs
}</syntaxhighlight>
{{out}}
<pre>boy → man: boy→bay→ban→man
girl → lady: girl→gill→gall→gale→gaze→laze→lazy→lady
john → jane: john→cohn→conn→cone→cane→jane
child → adult: impossible </pre>
=={{header|C++}}==
This borrows heavily from [[#Wren|Wren]] and a bit from [[#Raku|Raku]].
<
#include <fstream>
#include <iostream>
Line 59 ⟶ 521:
}
return result;
}
Line 79 ⟶ 535:
auto curr = queue.front();
queue.erase(queue.begin());
for (auto i = poss.begin(); i != poss.end();) {
}
if (
curr.push_back(to);
std::cout << join(curr.begin(), curr.end(), " -> ") << '\n';
return true;
}
std::vector<std::string> temp(curr);
temp.push_back(
queue.push_back(std::move(temp));
i = poss.erase(i);
}
}
Line 124 ⟶ 575:
word_ladder(words, "bubble", "tickle");
return EXIT_SUCCESS;
}</
{{out}}
Line 139 ⟶ 590:
=={{header|F_Sharp|F#}}==
<
// Word ladder: Nigel Galloway. June 5th., 2021
let fG n g=n|>List.partition(fun n->2>Seq.fold2(fun z n g->z+if n=g then 0 else 1) 0 n g)
Line 148 ⟶ 599:
let i,e=fG dict n in match i with Done i->Some([n;g]) |_->wL(i|>List.map(fun g->[g;n])) [] e
[("boy","man");("girl","lady");("john","jane");("child","adult")]|>List.iter(fun(n,g)->printfn "%s" (match wL n g with Some n->n|>String.concat " -> " |_->n+" into "+g+" can't be done"))
</syntaxhighlight>
{{out}}
<pre>
Line 159 ⟶ 610:
The bad news is evil can not be turned into good, but the good news is god can become man.
<
[("evil","good");("god","man")]|>List.iter(fun(n,g)->printfn "%s" (match wL n g with Some n->n|>String.concat " -> " |_->n+" into "+g+" can't be done"))
</syntaxhighlight>
{{out}}
<pre>
Line 170 ⟶ 621:
=={{header|Go}}==
{{trans|Wren}}
<
import (
Line 258 ⟶ 709:
wordLadder(words, pair[0], pair[1])
}
}</
{{out}}
Line 267 ⟶ 718:
child into adult cannot be done.
</pre>
=={{header|Haskell}}==
=== Breadth-first search===
The function first expands a ball around the starting word in the space of possible words, until the ball surface touches the goal (if ever). After that it performs depth-first path-finding from the goal back to the center.
<syntaxhighlight lang="haskell">import System.IO (readFile)
import Control.Monad (foldM)
import Data.List (intercalate)
import qualified Data.Set as S
distance :: String -> String -> Int
distance s1 s2 = length $ filter not $ zipWith (==) s1 s2
wordLadders :: [String] -> String -> String -> [[String]]
wordLadders dict start end
| length start /= length end = []
| otherwise = [wordSpace] >>= expandFrom start >>= shrinkFrom end
where
wordSpace = S.fromList $ filter ((length start ==) . length) dict
expandFrom s = go [[s]]
where
go (h:t) d
| S.null d || S.null f = []
| end `S.member` f = [h:t]
| otherwise = go (S.elems f:h:t) (d S.\\ f)
where
f = foldr (\w -> S.union (S.filter (oneStepAway w) d)) mempty h
shrinkFrom = scanM (filter . oneStepAway)
oneStepAway x = (1 ==) . distance x
scanM f x = fmap snd . foldM g (x,[x])
where g (b, r) a = (\x -> (x, x:r)) <$> f b a
wordLadder :: [String] -> String -> String -> [String]
wordLadder d s e = case wordLadders d s e of
[] -> []
h:_ -> h
showChain [] = putStrLn "No chain"
showChain ch = putStrLn $ intercalate " -> " ch
main = do
dict <- lines <$> readFile "unixdict.txt"
showChain $ wordLadder dict "boy" "man"
showChain $ wordLadder dict "girl" "lady"
showChain $ wordLadder dict "john" "jane"
showChain $ wordLadder dict "alien" "drool"
showChain $ wordLadder dict "child" "adult"</syntaxhighlight>
<pre>λ> lines <$> readFile "unixdict.txt" >>= print . wordLadders "boy" "man"
[["boy","bay","ban","man"],["boy","bon","ban","man"],["boy","bay","may","man"]]
λ> lines <$> readFile "unixdict.txt" >>= print . wordLadders "girl" "lady"
[["girl","gill","gall","gale","gaze","laze","lazy","lady"]]
λ> lines <$> readFile "unixdict.txt" >>= print . wordLadders "child" "adult"
[]
λ> main
boy -> bay -> ban -> man
girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady
john -> cohn -> conn -> cone -> cane -> jane
alien -> alden -> alder -> alter -> aster -> ester -> eater -> bater -> bator -> baton -> baron -> boron -> moron -> moran -> moral -> morel -> monel -> money -> monty -> month -> mouth -> south -> sooth -> sloth -> slosh -> slash -> flash -> flask -> flank -> blank -> bland -> blend -> bleed -> breed -> bread -> tread -> triad -> trial -> trill -> drill -> droll -> drool
No chain</pre>
=== Two-sided breadth-first search ===
Performs searching from both ends. This solution is much faster for cases with no chains, and for for short chains. In case of long chains looses its' efficiency.
<syntaxhighlight lang="haskell">wordLadders2 :: String -> String -> [String] -> [[String]]
wordLadders2 start end dict
| length start /= length end = []
| otherwise = pure wordSpace >>= expand start end >>= shrink end
where
wordSpace = S.fromList $ filter ((length start ==) . length) dict
expand s e d = tail . map S.elems <$> go [S.singleton s] [S.singleton e] d
where
go (hs:ts) (he:te) d
| S.null d || S.null fs || S.null fe = []
| not $ S.null f1 = [reverse (f1:te) ++ hs:ts]
| not $ S.null f2 = [reverse (he:te) ++ f2:ts]
| not $ S.null f3 = [reverse (he:te) ++ f3:hs:ts]
| otherwise = go (fs:hs:ts) (fe:he:te) (d S.\\ hs S.\\ he)
where
fs = front hs
fe = front he
f1 = fs `S.intersection` he
f2 = fe `S.intersection` hs
f3 = fs `S.intersection` fe
front = S.foldr (\w -> S.union (S.filter (oneStepAway w) d)) mempty
shrink = scanM (findM . oneStepAway)
oneStepAway x = (1 ==) . distance x
scanM f x = fmap snd . foldM g (x,[x])
where g (b, r) a = (\x -> (x, x:r)) <$> f b a
findM p = msum . map (\x -> if p x then pure x else mzero)</syntaxhighlight>
===Using A*-search===
See [[A*_search_algorithm#Haskell]]
<syntaxhighlight lang="haskell">import AStar (findPath, Graph(..))
import qualified Data.Map as M
distance :: String -> String -> Int
distance s1 s2 = length $ filter not $ zipWith (==) s1 s2
wordLadder :: [String] -> String -> String -> [String]
wordLadder dict start end = findPath g distance start end
where
short_dict = filter ((length start ==) . length) dict
g = Graph $ \w -> M.fromList [ (x, 1)
| x <- short_dict
, distance w x == 1 ]</syntaxhighlight>
<pre>λ> main
boy -> bay -> ban -> man
girl -> gird -> bird -> bard -> lard -> lark -> lack -> lacy -> lady
john -> cohn -> conn -> cone -> cane -> jane
alien -> alden -> alder -> alter -> aster -> ester -> eater -> bater -> bator -> baton -> baron -> boron -> moron -> moran -> moral -> morel -> monel -> money -> monty -> month -> mouth -> south -> sooth -> sloth -> slosh -> slash -> flash -> flask -> flank -> blank -> bland -> blend -> bleed -> breed -> bread -> tread -> triad -> trial -> trill -> drill -> droll -> drool
No chain</pre>
Works much faster when compiled.
=={{header|J}}==
Here we use a double ended breadth first search (starting from each end). This tends to give us several options where they meet in the middle, so we pick a shortest example from those.
<syntaxhighlight lang="j">extend=: {{
j=. {:y
l=. <:{:$m
<y,"1 0 I.l=m+/ .="1 j{m
}}
wlad=: {{
l=. #x assert. l=#y
words=. >(#~ l=#@>) cutLF fread 'unixdict.txt'
ix=. ,:words i.x assert. ix<#words
iy=. ,:words i.y assert. iy<#words
while. -. 1 e. ix e.&, iy do.
if. 0 e. ix,&# iy do. EMPTY return. end.
ix=. ; words extend"1 ix
if. -. 1 e. ix e.&, iy do.
iy=. ; words extend"1 iy
end.
end.
iy=. |."1 iy
r=. ix,&,iy
for_jk.(ix,&#iy)#:I.,ix +./@e."1/ iy do.
ixj=. ({.jk){ix
iyk=. ({:jk){iy
for_c. ixj ([-.-.) iyk do.
path=. (ixj{.~ixj i.c) , iyk}.~ iyk i.c
if. path <&# r do. r=. path end.
end.
end.
}.,' ',.r{words
}}</syntaxhighlight>
Task examples:<syntaxhighlight lang="j"> 'boy' wlad 'man'
boy bay ban man
'girl' wlad 'lady'
girl gill gall gale gaze laze lazy lady
'john' wlad 'jane'
john cohn conn cone cane jane
'child' wlad 'adult'
'cat' wlad 'dog'
cat cot cog dog
'lead' wlad 'gold'
lead load goad gold
'white' wlad 'black'
white whine chine chink clink blink blank black
'bubble' wlad 'tickle'
bubble babble gabble garble gargle gaggle giggle jiggle jingle tingle tinkle tickle</syntaxhighlight>
=={{header|Java}}==
<
import java.nio.file.Files;
import java.nio.file.Path;
Line 362 ⟶ 994:
wordLadder(words, "bubble", "tickle", 12);
}
}</
{{out}}
<pre>boy -> bay -> may -> man
Line 372 ⟶ 1,004:
white -> whine -> chine -> chink -> clink -> blink -> blank -> black
bubble -> babble -> gabble -> garble -> gargle -> gaggle -> waggle -> wangle -> tangle -> tingle -> tinkle -> tickle</pre>
===Faster alternative===
{{trans|C++}}
<syntaxhighlight lang="java">import java.io.*;
import java.util.*;
public class WordLadder {
public static void main(String[] args) {
try {
Map<Integer, List<String>> words = new HashMap<>();
try (BufferedReader reader = new BufferedReader(new FileReader("unixdict.txt"))) {
String line;
while ((line = reader.readLine()) != null)
words.computeIfAbsent(line.length(), k -> new ArrayList<String>()).add(line);
}
wordLadder(words, "boy", "man");
wordLadder(words, "girl", "lady");
wordLadder(words, "john", "jane");
wordLadder(words, "child", "adult");
wordLadder(words, "cat", "dog");
wordLadder(words, "lead", "gold");
wordLadder(words, "white", "black");
wordLadder(words, "bubble", "tickle");
} catch (Exception e) {
e.printStackTrace();
}
}
// Returns true if strings s1 and s2 differ by one character.
private static boolean oneAway(String s1, String s2) {
if (s1.length() != s2.length())
return false;
boolean result = false;
for (int i = 0, n = s1.length(); i != n; ++i) {
if (s1.charAt(i) != s2.charAt(i)) {
if (result)
return false;
result = true;
}
}
return result;
}
// If possible, print the shortest chain of single-character modifications that
// leads from "from" to "to", with each intermediate step being a valid word.
// This is an application of breadth-first search.
private static void wordLadder(Map<Integer, List<String>> words, String from, String to) {
List<String> w = words.get(from.length());
if (w != null) {
Deque<String> poss = new ArrayDeque<>(w);
Deque<String> f = new ArrayDeque<String>();
f.add(from);
Deque<Deque<String>> queue = new ArrayDeque<>();
queue.add(f);
while (!queue.isEmpty()) {
Deque<String> curr = queue.poll();
for (Iterator<String> i = poss.iterator(); i.hasNext(); ) {
String str = i.next();
if (!oneAway(str, curr.getLast()))
continue;
if (to.equals(str)) {
curr.add(to);
System.out.println(String.join(" -> ", curr));
return;
}
Deque<String> temp = new ArrayDeque<>(curr);
temp.add(str);
queue.add(temp);
i.remove();
}
}
}
System.out.printf("%s into %s cannot be done.\n", from, to);
}
}</syntaxhighlight>
{{out}}
<pre>
boy -> bay -> ban -> man
girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady
john -> cohn -> conn -> cone -> cane -> jane
child into adult cannot be done.
cat -> cot -> cog -> dog
lead -> load -> goad -> gold
white -> whine -> chine -> chink -> clink -> blink -> blank -> black
bubble -> babble -> gabble -> garble -> gargle -> gaggle -> giggle -> jiggle -> jingle -> tingle -> tinkle -> tickle
</pre>
=={{header|jq}}==
{{trans|Wren}}
{{works with|jq}}
'''Works with gojq, the Go implementation of jq'''
<syntaxhighlight lang="jq">def count(stream): reduce stream as $i (0; .+1);
def words: [inputs]; # one way to read the word list
def oneAway($a; $b):
($a|explode) as $ax
| ($b|explode) as $bx
| 1 == count(range(0; $a|length) | select($ax[.] != $bx[.]));
# input: the word list
def wordLadder($a; $b):
($a|length) as $len
| { poss: map(select(length == $len)), # the relevant words
todo: [[$a]] # possible chains
}
| until ( ((.todo|length) == 0) or .solution;
.curr = .todo[0]
| .todo |= .[1:]
| .curr[-1] as $c
| (.poss | map(select( oneAway(.; $c) ))) as $next
| if ($b | IN($next[]))
then .curr += [$b]
| .solution = (.curr|join(" -> "))
else .poss = (.poss - $next)
| .curr as $curr
| .todo = (reduce range(0; $next|length) as $i (.todo;
. + [$curr + [$next[$i] ]] ))
end )
| if .solution then .solution
else "There is no ladder from \($a) to \($b)."
end ;
def pairs:
["boy", "man"],
["girl", "lady"],
["john", "jane"],
["child", "adult"],
["word", "play"]
;
words
| pairs as $p
| wordLadder($p[0]; $p[1])</syntaxhighlight>
{{out}}
Invocation: jq -nr -R -f word-ladder.jq unixdict.txt
<pre>
boy -> bay -> ban -> man
girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady
john -> cohn -> conn -> cone -> cane -> jane
There is no ladder from child to adult.
word -> ford -> form -> foam -> flam -> clam -> clay -> play
</pre>
=={{header|Julia}}==
<
function targeted_mutations(str::AbstractString, target::AbstractString)
Line 400 ⟶ 1,177:
println("john to jane: ", targeted_mutations("john", "jane"))
println("child to adult: ", targeted_mutations("child", "adult"))
</
<pre>
boy to man: [["boy", "bay", "may", "man"], ["boy", "bay", "ban", "man"], ["boy", "bon", "ban", "man"]]
Line 410 ⟶ 1,187:
=={{header|Mathematica}} / {{header|Wolfram Language}}==
{{incorrect|Mathmatica|The requirement is to find the shortest path other examples do John to Jane with 4 intermediate words. Also an impossible example is required: child to adult.}}
<
sel=Select[Subsets[db,{2}],HammingDistance[#[[1]],#[[2]]]==1&];
g=Graph[db,UndirectedEdge@@@sel];
Line 424 ⟶ 1,201:
sel=Select[Subsets[db,{2}],HammingDistance[#[[1]],#[[2]]]==1&];
g=Graph[db,UndirectedEdge@@@sel];
FindShortestPath[g,"child","adult"]</
{{out}}
<pre>{"boy", "bay", "ban", "man"}
Line 432 ⟶ 1,209:
=={{header|Nim}}==
<
Line 487 ⟶ 1,264:
echo &"No path from “{start}” to “{target}”."
else:
echo path.join(" → ")</
{{out}}
Line 500 ⟶ 1,277:
=={{header|Perl}}==
===Direct translation===
{{trans|C++}}
<
use warnings;
Line 599 ⟶ 1,377:
word_ladder('lead', 'gold');
word_ladder('white', 'black');
word_ladder('bubble', 'tickle');</
{{out}}
<pre>boy -> bay -> ban -> man
Line 609 ⟶ 1,387:
white -> whine -> chine -> chink -> clink -> blink -> blank -> black
bubble -> babble -> gabble -> garble -> gargle -> gaggle -> giggle -> jiggle -> jingle -> tingle -> tinkle -> tickle</pre>
===Idiomatic version===
<b>Exactly</b> the same algorithm, written in a more Perl-ish style. Is this better, or worse? Maybe both. Interestingly, runs 1/3-rd faster.
<syntaxhighlight lang="perl">use strict;
use warnings;
use feature 'say';
my %dict;
open my $handle, '<', 'ref/unixdict.txt';
while (my $word = <$handle>) {
chomp $word;
my $l = length $word;
if ($dict{$l}) { push @{ $dict{$l} }, $word }
else { $dict{$l} = \@{[$word]} }
}
close $handle;
sub distance {
my($w1,$w2) = @_;
my $d;
substr($w1, $_, 1) eq substr($w2, $_, 1) or $d++ for 0 .. length($w1) - 1;
return $d // 0;
}
sub contains {
my($aref,$needle) = @_;
$needle eq $_ and return 1 for @$aref;
return 0;
}
sub word_ladder {
my($fw,$tw) = @_;
say 'Nothing like that in dictionary.' and return unless $dict{length $fw};
my @poss = @{ $dict{length $fw} };
my @queue = [$fw];
while (@queue) {
my $curr_ref = shift @queue;
my $last = $curr_ref->[-1];
my @next;
distance($last, $_) == 1 and push @next, $_ for @poss;
push(@$curr_ref, $tw) and say join ' -> ', @$curr_ref and return if contains \@next, $tw;
for my $word (@next) {
$word eq $poss[$_] and splice(@poss, $_, 1) and last for 0 .. @poss - 1;
}
push @queue, \@{[@{$curr_ref}, $_]} for @next;
}
say "Cannot change $fw into $tw";
}
word_ladder(split) for 'boy man', 'girl lady', 'john jane', 'child adult';</syntaxhighlight>
Same style output.
=={{header|Phix}}==
<!--<
<span style="color: #008080;">with</span> <span style="color: #008080;">javascript_semantics</span>
<span style="color: #004080;">sequence</span> <span style="color: #000000;">words</span> <span style="color: #0000FF;">=</span> <span style="color: #7060A8;">unix_dict</span><span style="color: #0000FF;">()</span>
Line 641 ⟶ 1,474:
<span style="color: #000000;">word_ladder</span><span style="color: #0000FF;">(</span><span style="color: #008000;">"john"</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"jane"</span><span style="color: #0000FF;">)</span>
<span style="color: #000000;">word_ladder</span><span style="color: #0000FF;">(</span><span style="color: #008000;">"child"</span><span style="color: #0000FF;">,</span><span style="color: #008000;">"adult"</span><span style="color: #0000FF;">)</span>
<!--</
<small>Aside: an initial poss = filter(poss,"out",{a}) might be prudent, but would only prevent a single next:={} step, at about the same cost as the initial filter anyway.</small>
{{out}}
Line 653 ⟶ 1,486:
=={{header|Python}}==
The function ''cache'' is not part of the algorithm but avoid re-download and map re-computing at each re-run.
<
def h ( str,x=9 ):
Line 700 ⟶ 1,533:
for w in ('boy man','girl lady','john jane','alien drool','child adult'):
print( find_path( cache( build_map,load_dico( dico_url )),*w.split()))</
{{out}}
Line 713 ⟶ 1,546:
=={{header|Racket}}==
<
(define *unixdict* (delay (with-input-from-file "../../data/unixdict.txt"
Line 753 ⟶ 1,586:
(Word-ladder "john" "jane")
(Word-ladder "alien" "drool")
(Word-ladder "child" "adult"))</
{{out}}
Line 804 ⟶ 1,637:
=={{header|Raku}}==
<syntaxhighlight lang="raku"
.classify(*.chars)
.map({ .key => .value.Set });
Line 840 ⟶ 1,673:
say word_ladder($from, $to)
// "$from into $to cannot be done";
}</
{{out}}
<pre>
Line 847 ⟶ 1,680:
(john cohn conn cone cane jane)
child into adult cannot be done</pre>
=={{header|Refal}}==
This program needs to be run with <tt>refal -l48</tt> to allocate enough memory for it to run.
<syntaxhighlight lang="refal">$ENTRY Go {
, <ReadFile 1 'unixdict.txt'>: e.Dict
= <DisplayLadder (e.Dict) ('boy') ('man')>
<DisplayLadder (e.Dict) ('girl') ('lady')>
<DisplayLadder (e.Dict) ('john') ('jane')>
<DisplayLadder (e.Dict) ('child') ('adult')>;
};
DisplayLadder {
(e.Dict) (e.From) (e.To),
e.From ' -> ' e.To ': ': e.Header,
<Ladder (e.Dict) (e.From) (e.To)>: {
Impossible = <Prout e.Header 'impossible'>;
Result e.Words = <Prout e.Header <Join ('->') e.Words>>;
};
};
Join {
(e.Join) = ;
(e.Join) (e.Word) = e.Word;
(e.Join) (e.Word) e.Words = e.Word e.Join <Join (e.Join) e.Words>;
};
ReadFile {
s.Chan e.File =
<Open 'r' s.Chan e.File>
<ReadFile (s.Chan)>;
(s.Chan), <Get s.Chan>: {
0 = ;
e.Line = (e.Line) <ReadFile (s.Chan)>;
};
};
Filter {
(e.Fn) = ;
(e.Fn) t.Item e.Items, <Mu e.Fn t.Item>: {
True = t.Item <Filter (e.Fn) e.Items>;
False = <Filter (e.Fn) e.Items>;
};
};
SameLen {
(e.Word1) (e.Word2),
<Lenw e.Word1>: s.Len e.Word1,
<Lenw e.Word2>: s.Len e.Word2 = True;
(e.Word1) (e.Word2) = False;
};
Diffs {
() () = 0;
(s.X e.Word1) (s.X e.Word2) = <Diffs (e.Word1) (e.Word2)>;
(s.X e.Word1) (s.Y e.Word2) = <+ 1 <Diffs (e.Word1) (e.Word2)>>;
};
OneDiff {
t.Word1 t.Word2, <Diffs t.Word1 t.Word2>: {
1 = True;
s.Diffs = False;
};
};
Ladder {
(e.Dict) t.From t.To,
<Filter (SameLen t.From) e.Dict>: e.Dict2 =
<Ladder2 ((t.From)) (e.Dict2) t.To>;
};
Ladder2 {
(e.Ladders) (e.Dict) t.To,
e.Ladders: e.X (e.Words t.To) e.Y = Result e.Words t.To;
(e.Ladders) () t.To = Impossible;
() (e.Dict) t.To = Impossible;
((e.Ladder) e.Ladders) (e.Dict) t.To,
e.Ladder: e.1 t.Last,
<Filter (OneDiff t.Last) e.Dict>: e.NextWords,
<RemoveAll (e.NextWords) e.Dict>: e.NextDict,
<AddAll (e.Ladder) e.NextWords>: e.NextLadders
= <Ladder2 (e.Ladders e.NextLadders) (e.NextDict) t.To>;
};
RemoveAll {
(e.Remove) = ;
(e.Remove) t.Word e.Words, e.Remove: {
e.X t.Word e.Y = <RemoveAll (e.Remove) e.Words>;
e.Remove = t.Word <RemoveAll (e.Remove) e.Words>;
};
};
AddAll {
(e.Ladder) = ;
(e.Ladder) t.Word e.Words =
(e.Ladder t.Word) <AddAll (e.Ladder) e.Words>;
};</syntaxhighlight>
{{out}}
<pre>boy -> man: boy->bay->ban->man
girl -> lady: girl->gill->gall->gale->gaze->laze->lazy->lady
john -> jane: john->cohn->conn->cone->cane->jane
child -> adult: impossible</pre>
=={{header|REXX}}==
Line 857 ⟶ 1,793:
Programming note: this REXX program uses the '''lower''' BIF which Regina has).
<br>If your REXX doesn't support that BIF, here is an equivalent function:
<
return translate(a, @, @u)</
<
parse arg base targ iFID . /*obtain optional arguments from the CL*/
if base=='' | base=="," then base= 'boy' /*Not specified? Then use the default.*/
Line 916 ⟶ 1,852:
end /*k*/
end /*i*/
$= $$; return ''</
{{out|output|text= when using the default inputs:}}
<pre>
Line 968 ⟶ 1,904:
no word ladder solution possible for child ──► adult
</pre>
=={{header|Ruby}}==
{{trans|Raku}}
<syntaxhighlight lang="ruby">require "set"
Words = File.open("unixdict.txt").read.split("\n").
group_by { |w| w.length }.map { |k, v| [k, Set.new(v)] }.
to_h
def word_ladder(from, to)
raise "Length mismatch" unless from.length == to.length
sized_words = Words[from.length]
work_queue = [[from]]
used = Set.new [from]
while work_queue.length > 0
new_q = []
work_queue.each do |words|
last_word = words[-1]
new_tails = Enumerator.new do |enum|
("a".."z").each do |replacement_letter|
last_word.length.times do |i|
new_word = last_word.clone
new_word[i] = replacement_letter
next unless sized_words.include? new_word and
not used.include? new_word
enum.yield new_word
used.add new_word
return words + [new_word] if new_word == to
end
end
end
new_tails.each do |t|
new_q.push(words + [t])
end
end
work_queue = new_q
end
end
[%w<boy man>, %w<girl lady>, %w<john jane>, %w<child adult>].each do |from, to|
if ladder = word_ladder(from, to)
puts ladder.join " → "
else
puts "#{from} into #{to} cannot be done"
end
end</syntaxhighlight>
{{Out}}
<pre>boy → bay → may → man
girl → gill → gall → gale → gaze → laze → lazy → lady
john → cohn → conn → cone → cane → jane
child into adult cannot be done</pre>
=={{header|SETL}}==
<syntaxhighlight lang="setl">program word_ladder;
dict := read_dictionary("unixdict.txt");
testpairs := [['boy', 'man'], ['girl', 'lady'], ['john', 'jane'], ['child', 'adult']];
loop for [fromWord, toWord] in testpairs do
l := ladder(dict, fromWord, toWord);
if l = om then
print(fromWord, '->', toWord, 'impossible');
else
print(fromWord, '->', toWord, l);
end if;
end loop;
proc ladder(dict, fromWord, toWord);
dict := {word : word in dict | #word = #fromWord};
ladders := [[fromWord]];
dict less:= fromWord;
loop while ladders /= [] do
l fromb ladders;
next := {word : word in onediff(dict, l(#l))};
dict -:= next;
nextls := [l + [word] : word in next];
if exists l in nextls | l(#l) = toWord then
return l;
end if;
ladders +:= nextls;
end loop;
return om;
end proc;
proc onediff(rw dict, word);
return {other : other in dict | #other = #word and diffs(word, other) = 1};
end proc;
proc diffs(word1, word2);
return +/[if word1(i) = word2(i) then 0 else 1 end : i in [1..#word1]];
end proc;
proc read_dictionary(file);
dictfile := open(file, 'r');
dict := {getline(dictfile) : until eof(dictfile)};
close(dictfile);
return dict;
end proc;
end program;</syntaxhighlight>
{{out}}
<pre>boy -> man [boy bay ban man]
girl -> lady [girl gill gall gale gaze laze lazy lady]
john -> jane [john cohn conn cone cane jane]
child -> adult impossible</pre>
=={{header|Swift}}==
{{trans|Wren}}
<
func oneAway(string1:
if string1.count != string2.count {
return false
}
var result = false
var i = 0
while i <
if string1[i] != string2[i] {
if result {
return false
Line 985 ⟶ 2,026:
result = true
}
i += 1
}
return result
}
func wordLadder(words: [
var poss = words.filter{$0.count == fromCh.count}
var queue: [[[Character]]] = [[fromCh]]
while !queue.isEmpty {
var curr = queue[0]
Line 997 ⟶ 2,041:
queue.removeFirst()
let next = poss.filter{oneAway(string1: $0, string2: last)}
if next.contains(
curr.append(
print(curr.map{String($0)}.joined(separator: " -> "))
return
}
Line 1,016 ⟶ 2,060:
.components(separatedBy: "\n")
.filter{!$0.isEmpty}
.map{Array($0)}
wordLadder(words: words, from: "man", to: "boy")
wordLadder(words: words, from: "girl", to: "lady")
wordLadder(words: words, from: "john", to: "jane")
wordLadder(words: words, from: "child", to: "adult")
wordLadder(words: words, from: "cat", to: "dog")
wordLadder(words: words, from: "lead", to: "gold")
wordLadder(words: words, from: "white", to: "black")
wordLadder(words: words, from: "bubble", to: "tickle")
} catch {
print(error.localizedDescription)
}</
{{out}}
Line 1,030 ⟶ 2,079:
john -> cohn -> conn -> cone -> cane -> jane
child into adult cannot be done.
cat -> cot -> cog -> dog
lead -> load -> goad -> gold
white -> whine -> chine -> chink -> clink -> blink -> blank -> black
bubble -> babble -> gabble -> garble -> gargle -> gaggle -> giggle -> jiggle -> jingle -> tingle -> tinkle -> tickle
</pre>
Line 1,035 ⟶ 2,088:
{{trans|Phix}}
{{libheader|Wren-sort}}
<
import "./sort" for Find
var words = File.read("unixdict.txt").trim().split("\n")
Line 1,075 ⟶ 2,128:
["child", "adult"]
]
for (pair in pairs) wordLadder.call(pair[0], pair[1])</
{{out}}
|
Latest revision as of 10:29, 10 July 2024
![Task](http://static.miraheze.org/rosettacodewiki/thumb/b/ba/Rcode-button-task-crushed.png/64px-Rcode-button-task-crushed.png)
You are encouraged to solve this task according to the task description, using any language you may know.
Yet another shortest path problem. Given two words of equal length the task is to transpose the first into the second.
Only one letter may be changed at a time and the change must result in a word in unixdict, the minimum number of intermediate words should be used.
Demonstrate the following:
A boy can be made into a man: boy -> bay -> ban -> man
With a little more difficulty a girl can be made into a lady: girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady
A john can be made into a jane: john -> cohn -> conn -> cone -> cane -> jane
A child can not be turned into an adult.
Optional transpositions of your choice.
- Metrics
- Counting
- Word frequency
- Letter frequency
- Jewels and stones
- I before E except after C
- Bioinformatics/base count
- Count occurrences of a substring
- Count how many vowels and consonants occur in a string
- Remove/replace
- XXXX redacted
- Conjugate a Latin verb
- Remove vowels from a string
- String interpolation (included)
- Strip block comments
- Strip comments from a string
- Strip a set of characters from a string
- Strip whitespace from a string -- top and tail
- Strip control codes and extended characters from a string
- Anagrams/Derangements/shuffling
- Word wheel
- ABC problem
- Sattolo cycle
- Knuth shuffle
- Ordered words
- Superpermutation minimisation
- Textonyms (using a phone text pad)
- Anagrams
- Anagrams/Deranged anagrams
- Permutations/Derangements
- Find/Search/Determine
- ABC words
- Odd words
- Word ladder
- Semordnilap
- Word search
- Wordiff (game)
- String matching
- Tea cup rim text
- Alternade words
- Changeable words
- State name puzzle
- String comparison
- Unique characters
- Unique characters in each string
- Extract file extension
- Levenshtein distance
- Palindrome detection
- Common list elements
- Longest common suffix
- Longest common prefix
- Compare a list of strings
- Longest common substring
- Find common directory path
- Words from neighbour ones
- Change e letters to i in words
- Non-continuous subsequences
- Longest common subsequence
- Longest palindromic substrings
- Longest increasing subsequence
- Words containing "the" substring
- Sum of the digits of n is substring of n
- Determine if a string is numeric
- Determine if a string is collapsible
- Determine if a string is squeezable
- Determine if a string has all unique characters
- Determine if a string has all the same characters
- Longest substrings without repeating characters
- Find words which contains all the vowels
- Find words which contain the most consonants
- Find words which contains more than 3 vowels
- Find words whose first and last three letters are equal
- Find words with alternating vowels and consonants
- Formatting
- Substring
- Rep-string
- Word wrap
- String case
- Align columns
- Literals/String
- Repeat a string
- Brace expansion
- Brace expansion using ranges
- Reverse a string
- Phrase reversals
- Comma quibbling
- Special characters
- String concatenation
- Substring/Top and tail
- Commatizing numbers
- Reverse words in a string
- Suffixation of decimal numbers
- Long literals, with continuations
- Numerical and alphabetical suffixes
- Abbreviations, easy
- Abbreviations, simple
- Abbreviations, automatic
- Song lyrics/poems/Mad Libs/phrases
- Mad Libs
- Magic 8-ball
- 99 bottles of beer
- The Name Game (a song)
- The Old lady swallowed a fly
- The Twelve Days of Christmas
- Tokenize
- Text between
- Tokenize a string
- Word break problem
- Tokenize a string with escaping
- Split a character string based on change of character
- Sequences
11l
F isOneAway(word1, word2)
V result = 0B
L(i) 0 .< word1.len
I word1[i] != word2[i]
I result
R 0B
E
result = 1B
R result
DefaultDict[Int, [String]] words
L(word) File(‘unixdict.txt’).read().split("\n")
words[word.len] [+]= word
F find_path(start, target)
V lg = start.len
assert(target.len == lg, ‘Source and destination must have same length.’)
assert(start C :words[lg], ‘Source must exist in the dictionary.’)
assert(target C :words[lg], ‘Destination must exist in the dictionary.’)
V currPaths = [[start]]
V pool = copy(:words[lg])
L
[[String]] newPaths
[String] added
L(candidate) pool
L(path) currPaths
I isOneAway(candidate, path.last)
V newPath = path [+] [candidate]
I candidate == target
R newPath
E
newPaths.append(newPath)
added.append(candidate)
L.break
I newPaths.empty
L.break
currPaths = move(newPaths)
L(w) added
pool.remove(w)
R [String]()
L(start, target) [(‘boy’, ‘man’), (‘girl’, ‘lady’), (‘john’, ‘jane’), (‘child’, ‘adult’), (‘cat’, ‘dog’), (‘lead’, ‘gold’), (‘white’, ‘black’), (‘bubble’, ‘tickle’)]
V path = find_path(start, target)
I path.empty
print(‘No path from "’start‘" to "’target‘".’)
E
print(path.join(‘ -> ’))
- Output:
boy -> bay -> ban -> man girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady john -> cohn -> conn -> cone -> cane -> jane No path from "child" to "adult". cat -> cot -> cog -> dog lead -> load -> goad -> gold white -> whine -> chine -> chink -> clink -> blink -> blank -> black bubble -> babble -> gabble -> garble -> gargle -> gaggle -> giggle -> jiggle -> jingle -> tingle -> tinkle -> tickle
Ada
Changed my solution to use Multiway_Trees.
pragma Ada_2022;
with Ada.Containers.Multiway_Trees;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Text_IO.Unbounded_IO; use Ada.Text_IO.Unbounded_IO;
procedure Word_Ladder is
DICT_FILENAME : constant String := "unixdict.txt";
MAX_DEPTH : constant Positive := 50;
subtype LC_Chars is Character range 'a' .. 'z';
type Word_Node_T is record
Level : Positive;
Word : Unbounded_String;
end record;
package Word_Vectors is new Ada.Containers.Vectors (Positive, Unbounded_String);
package Dict_Vectors is new Ada.Containers.Vectors (Positive, Unbounded_String);
package Word_Trees is new Ada.Containers.Multiway_Trees (Word_Node_T);
use Word_Trees;
Word_Tree : Tree;
Solved : Boolean;
Solution : Cursor;
function Load_Candidate_Words (Dict_Filename : String; Word_Len : Positive)
return Dict_Vectors.Vector is
Dict_File : File_Type;
Read_Word : Unbounded_String;
Cands : Dict_Vectors.Vector;
Valid : Boolean;
C : Character;
begin
Open (File => Dict_File, Mode => In_File, Name => Dict_Filename);
while not End_Of_File (Dict_File) loop
Read_Word := Get_Line (Dict_File);
if Length (Read_Word) = Word_Len then
Valid := True;
for Ix in 1 .. Word_Len loop
C := Element (Read_Word, Ix);
Valid := C in LC_Chars;
exit when not Valid;
end loop;
if Valid then Cands.Append (Read_Word); end if;
end if;
end loop;
Close (Dict_File);
return Cands;
end Load_Candidate_Words;
function Mutate (Word : Unbounded_String; Dict : in out Dict_Vectors.Vector)
return Word_Vectors.Vector is
Mutations : Word_Vectors.Vector;
Poss_Word : Unbounded_String;
begin
for Ix in 1 .. Length (Word) loop
for Letter in LC_Chars loop
if Letter /= Element (Word, Ix) then
Poss_Word := Word;
Replace_Element (Poss_Word, Ix, Letter);
if Dict.Contains (Poss_Word) then
Mutations.Append (Poss_Word);
Dict.Delete (Dict.Find_Index (Poss_Word));
end if;
end if;
end loop;
end loop;
return Mutations;
end Mutate;
procedure Recurse_Tree (Start_Pos : Cursor;
Level : Positive;
Target : Unbounded_String;
Dict : in out Dict_Vectors.Vector) is
Pos : Cursor := Start_Pos;
Mutations : Word_Vectors.Vector;
New_Node : Word_Node_T;
begin
while not Solved and then Pos /= No_Element loop
if Element (Pos).Level = Level then
Mutations := Mutate (Element (Pos).Word, Dict);
if not Word_Vectors.Is_Empty (Mutations) then
for Word of Mutations loop
New_Node.Level := Level + 1;
New_Node.Word := Word;
Append_Child (Word_Tree, Pos, New_Node);
if Word = Target then
Solved := True;
Solution := Pos;
end if;
end loop;
end if;
end if;
if not Solved then
Recurse_Tree (First_Child (Pos), Level, Target, Dict);
end if;
Pos := Next_Sibling (Pos);
end loop;
end Recurse_Tree;
procedure Ladder (Start_S, Target_S : String) is
Dictionary : Dict_Vectors.Vector;
Level : Positive := 1;
Word_Node : Word_Node_T;
Start, Target : Unbounded_String;
Start_Pos : Cursor;
Output : Unbounded_String;
begin
if Start_S'Length /= Target_S'Length then
Put_Line ("ERROR: Start and Target words must be same length.");
return;
end if;
Dictionary := Load_Candidate_Words (DICT_FILENAME, Start_S'Length);
Start := To_Unbounded_String (Start_S);
Target := To_Unbounded_String (Target_S);
Solved := False;
Word_Node.Level := 1;
Word_Node.Word := Start;
Word_Tree := Empty_Tree;
Word_Tree.Insert_Child (Word_Tree.Root, No_Element, Word_Node);
Start_Pos := Find (Word_Tree, Word_Node);
while Level <= MAX_DEPTH and then not Solved loop
Recurse_Tree (Start_Pos, Level, Target, Dictionary);
Level := @ + 1;
end loop;
if not Solved then
Put_Line (Start & " -> " & Target & " - No solution found at depth" & MAX_DEPTH'Image);
else
while not Is_Root (Solution) loop
Word_Node := Element (Solution);
Output := Word_Node.Word & " -> " & Output;
Solution := Parent (Solution);
end loop;
Put_Line (Output & Target);
end if;
end Ladder;
begin
Ladder ("boy", "man");
Ladder ("girl", "lady");
Ladder ("jane", "john");
Ladder ("child", "adult");
Ladder ("ada", "god");
Ladder ("rust", "hell");
end Word_Ladder;
- Output:
As expected "ada" can become a "god", and "rust" can go to "hell" :-)
boy -> bay -> may -> man girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady jane -> cane -> cone -> conn -> cohn -> john child -> adult - No solution found at depth 50 ada -> fda -> faa -> fad -> gad -> god rust -> bust -> best -> belt -> bell -> hell
ALGOL 68
With a68g use option --storage 2
, otherwise it runs out of memory.
# quick implementation of a stack of INT.
real program starts after it.
#
MODE STACK = STRUCT (INT top, FLEX[1:0]INT data, INT increment);
PROC makestack = (INT increment)STACK: (1, (), increment);
PROC pop = (REF STACK s)INT: ( top OF s -:= 1; (data OF s)[top OF s] );
PROC push = (REF STACK s, INT n)VOID:
BEGIN
IF top OF s > UPB data OF s THEN
[ UPB data OF s + increment OF s ]INT tmp;
tmp[1 : UPB data OF s] := data OF s;
data OF s := tmp
FI;
(data OF s)[top OF s] := n;
top OF s +:= 1
END;
PROC empty = (REF STACK s)BOOL: top OF s <= 1;
PROC contents = (REF STACK s)[]INT: (data OF s)[:top OF s - 1];
# start solution #
[]STRING words = BEGIN # load dictionary file into array #
FILE f;
BOOL eof := FALSE;
open(f, "unixdict.txt", stand in channel);
on logical file end(f, (REF FILE f)BOOL: eof := TRUE);
INT idx := 1;
FLEX [1:0] STRING words;
STRING word;
WHILE NOT eof DO
get(f, (word, newline));
IF idx > UPB words THEN
HEAP [1 : UPB words + 10000]STRING tmp;
tmp[1 : UPB words] := words;
words := tmp
FI;
words[idx] := word;
idx +:= 1
OD;
words[1:idx-1]
END;
INT nwords = UPB words;
INT max word length = (INT mwl := 0;
FOR i TO UPB words DO
IF mwl < UPB words[i] THEN mwl := UPB words[i] FI
OD;
mwl);
[nwords]FLEX[0]INT neighbors;
[max word length]BOOL precalculated by length;
FOR i TO UPB precalculated by length DO precalculated by length[i] := FALSE OD;
# precalculating neighbours takes time, but not doing it is even slower... #
PROC precalculate neighbors = (INT word length)VOID:
BEGIN
[nwords]REF STACK stacks;
FOR i TO UPB stacks DO stacks[i] := NIL OD;
FOR i TO UPB words DO
IF UPB words[i] = word length THEN
IF REF STACK(stacks[i]) :=: NIL THEN stacks[i] := HEAP STACK := makestack(10) FI;
FOR j FROM i + 1 TO UPB words DO
IF UPB words[j] = word length THEN
IF neighboring(words[i], words[j]) THEN
push(stacks[i], j);
IF REF STACK(stacks[j]) :=: NIL THEN stacks[j] := HEAP STACK := makestack(10) FI;
push(stacks[j], i)
FI
FI
OD
FI
OD;
FOR i TO UPB neighbors DO
IF REF STACK(stacks[i]) :/=: NIL THEN
neighbors[i] := contents(stacks[i])
FI
OD;
precalculated by length [word length] := TRUE
END;
PROC neighboring = (STRING a, b)BOOL: # do a & b differ in just 1 char? #
BEGIN
INT diff := 0;
FOR i TO UPB a DO IF a[i] /= b[i] THEN diff +:= 1 FI OD;
diff = 1
END;
PROC word ladder = (STRING from, STRING to)[]STRING:
BEGIN
IF UPB from /= UPB to THEN fail FI;
INT word length = UPB from;
IF word length < 1 OR word length > max word length THEN fail FI;
IF from = to THEN fail FI;
INT start := 0;
INT destination := 0;
FOR i TO UPB words DO
IF UPB words[i] = word length THEN
IF words[i] = from THEN start := i
ELIF words[i] = to THEN destination := i
FI
FI
OD;
IF destination = 0 OR start = 0 THEN fail FI;
IF NOT precalculated by length [word length] THEN
precalculate neighbors(word length)
FI;
STACK stack := makestack(1000);
[nwords]INT distance;
[nwords]INT previous;
FOR i TO nwords DO distance[i] := nwords+1; previous[i] := 0 OD;
INT shortest := nwords+1;
distance[start] := 0;
push(stack, start);
WHILE NOT empty(stack)
DO
INT curr := pop(stack);
INT dist := distance[curr];
IF dist < shortest - 1 THEN
# find neighbors and add them to the stack #
FOR i FROM UPB neighbors[curr] BY -1 TO 1 DO
INT n = neighbors[curr][i];
IF distance[n] > dist + 1 THEN
distance[n] := dist + 1;
previous[n] := curr;
IF n = destination THEN
shortest := dist + 1
ELSE
push(stack, n)
FI
FI
OD;
IF curr = destination THEN shortest := dist FI
FI
OD;
INT length = distance[destination] + 1;
IF length > nwords THEN fail FI;
[length]STRING result;
INT curr := destination;
FOR i FROM length BY -1 TO 1
DO
result[i] := words[curr];
curr := previous[curr]
OD;
result EXIT
fail: LOC [0] STRING
END;
[][]STRING pairs = (("boy", "man"), ("bed", "cot"),
("old", "new"), ("dry", "wet"),
("girl", "lady"), ("john", "jane"),
("lead", "gold"), ("poor", "rich"),
("lamb", "stew"), ("kick", "goal"),
("cold", "warm"), ("nude", "clad"),
("child", "adult"), ("white", "black"),
("bread", "toast"), ("lager", "stout"),
("bride", "groom"), ("table", "chair"),
("bubble", "tickle"));
FOR i TO UPB pairs
DO
STRING from = pairs[i][1], to = pairs[i][2];
[]STRING ladder = word ladder(from, to);
IF UPB ladder = 0
THEN print(("No solution for """ + from + """ -> """ + to + """", newline))
ELSE FOR j TO UPB ladder DO print(((j > 1 | "->" | ""), ladder[j])) OD;
print(newline)
FI
OD
- Output:
boy->bay->ban->man bed->bad->bat->cat->cot old->odd->ode->one->nne->nee->new dry->dey->bey->bet->wet girl->gill->gall->gale->gaze->laze->lazy->lady john->cohn->conn->cone->cane->jane lead->load->goad->gold poor->boor->book->bock->rock->rick->rich lamb->lame->laue->laud->saud->spud->sped->spew->stew kick->dick->dock->cock->cook->cool->coal->goal cold->cord->card->ward->warm nude->node->bode->bole->bold->gold->goad->glad->clad No solution for "child" -> "adult" white->whine->chine->chink->clink->blink->blank->black bread->break->bleak->bleat->blest->blast->boast->toast lager->hager->hagen->haven->raven->ravel->navel->novel->hovel->hotel->motel->monel->money->honey->haney->handy->dandy->danny->denny->penny->peony->phony->phone->shone->shore->short->shout->stout bride->brice->brick->brock->brook->broom->groom No solution for "table" -> "chair" bubble->babble->gabble->garble->gargle->gaggle->giggle->jiggle->jingle->tingle->tinkle->tickle
APL
wordladder←{
from to←⍵
dict←((≢¨⍺)=≢to)/⍺
dict{
match←(⊂to)≡¨⊃∘⌽¨⍵
∨/match:⊃match/⍵
0∊≢¨⍺⍵:⍬
word←⊃⌽ladder←⊃⍵
next←(1=⍺+.≠¨⊂word)/⍺
(⍺~next)∇(1↓⍵),(⊂ladder),¨⊂¨next
}⊂⊂from
}
task←{
dict←(~dict∊⎕TC)⊆dict←⊃⎕NGET'unixdict.txt'
pairs←('boy' 'man')('girl' 'lady')('john' 'jane')('child' 'adult')
⎕←↑↑{
hdr←⍺,' → ',⍵,': '
ladder←dict wordladder ⍺ ⍵
0=≢ladder:hdr,'impossible'
hdr,1↓∊'→',¨ladder
}/¨pairs
}
- Output:
boy → man: boy→bay→ban→man girl → lady: girl→gill→gall→gale→gaze→laze→lazy→lady john → jane: john→cohn→conn→cone→cane→jane child → adult: impossible
C++
This borrows heavily from Wren and a bit from Raku.
#include <algorithm>
#include <fstream>
#include <iostream>
#include <map>
#include <string>
#include <vector>
using word_map = std::map<size_t, std::vector<std::string>>;
// Returns true if strings s1 and s2 differ by one character.
bool one_away(const std::string& s1, const std::string& s2) {
if (s1.size() != s2.size())
return false;
bool result = false;
for (size_t i = 0, n = s1.size(); i != n; ++i) {
if (s1[i] != s2[i]) {
if (result)
return false;
result = true;
}
}
return result;
}
// Join a sequence of strings into a single string using the given separator.
template <typename iterator_type, typename separator_type>
std::string join(iterator_type begin, iterator_type end,
separator_type separator) {
std::string result;
if (begin != end) {
result += *begin++;
for (; begin != end; ++begin) {
result += separator;
result += *begin;
}
}
return result;
}
// If possible, print the shortest chain of single-character modifications that
// leads from "from" to "to", with each intermediate step being a valid word.
// This is an application of breadth-first search.
bool word_ladder(const word_map& words, const std::string& from,
const std::string& to) {
auto w = words.find(from.size());
if (w != words.end()) {
auto poss = w->second;
std::vector<std::vector<std::string>> queue{{from}};
while (!queue.empty()) {
auto curr = queue.front();
queue.erase(queue.begin());
for (auto i = poss.begin(); i != poss.end();) {
if (!one_away(*i, curr.back())) {
++i;
continue;
}
if (to == *i) {
curr.push_back(to);
std::cout << join(curr.begin(), curr.end(), " -> ") << '\n';
return true;
}
std::vector<std::string> temp(curr);
temp.push_back(*i);
queue.push_back(std::move(temp));
i = poss.erase(i);
}
}
}
std::cout << from << " into " << to << " cannot be done.\n";
return false;
}
int main() {
word_map words;
std::ifstream in("unixdict.txt");
if (!in) {
std::cerr << "Cannot open file unixdict.txt.\n";
return EXIT_FAILURE;
}
std::string word;
while (getline(in, word))
words[word.size()].push_back(word);
word_ladder(words, "boy", "man");
word_ladder(words, "girl", "lady");
word_ladder(words, "john", "jane");
word_ladder(words, "child", "adult");
word_ladder(words, "cat", "dog");
word_ladder(words, "lead", "gold");
word_ladder(words, "white", "black");
word_ladder(words, "bubble", "tickle");
return EXIT_SUCCESS;
}
- Output:
boy -> bay -> ban -> man girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady john -> cohn -> conn -> cone -> cane -> jane child into adult cannot be done. cat -> cot -> cog -> dog lead -> load -> goad -> gold white -> whine -> chine -> chink -> clink -> blink -> blank -> black bubble -> babble -> gabble -> garble -> gargle -> gaggle -> giggle -> jiggle -> jingle -> tingle -> tinkle -> tickle
F#
// Word ladder: Nigel Galloway. June 5th., 2021
let fG n g=n|>List.partition(fun n->2>Seq.fold2(fun z n g->z+if n=g then 0 else 1) 0 n g)
let wL n g=let dict=seq{use n=System.IO.File.OpenText("unixdict.txt") in while not n.EndOfStream do yield n.ReadLine()}|>Seq.filter(Seq.length>>(=)(Seq.length n))|>List.ofSeq|>List.except [n]
let (|Done|_|) n=n|>List.tryFind((=)g)
let rec wL n g l=match n with h::t->let i,e=fG l (List.head h) in match i with Done i->Some((i::h)|>List.rev) |_->wL t ((i|>List.map(fun i->i::h))@g) e
|_->match g with []->None |_->wL g [] l
let i,e=fG dict n in match i with Done i->Some([n;g]) |_->wL(i|>List.map(fun g->[g;n])) [] e
[("boy","man");("girl","lady");("john","jane");("child","adult")]|>List.iter(fun(n,g)->printfn "%s" (match wL n g with Some n->n|>String.concat " -> " |_->n+" into "+g+" can't be done"))
- Output:
boy -> bay -> ban -> man girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady john -> cohn -> conn -> cone -> cane -> jane child into adult can't be done
Optional transpositions
The bad news is evil can not be turned into good, but the good news is god can become man.
[("evil","good");("god","man")]|>List.iter(fun(n,g)->printfn "%s" (match wL n g with Some n->n|>String.concat " -> " |_->n+" into "+g+" can't be done"))
- Output:
evil into good can't be done done god -> gad -> mad -> man
Go
package main
import (
"bytes"
"fmt"
"io/ioutil"
"log"
"strings"
)
func contains(a []string, s string) bool {
for _, e := range a {
if e == s {
return true
}
}
return false
}
func oneAway(a, b string) bool {
sum := 0
for i := 0; i < len(a); i++ {
if a[i] != b[i] {
sum++
}
}
return sum == 1
}
func wordLadder(words []string, a, b string) {
l := len(a)
var poss []string
for _, word := range words {
if len(word) == l {
poss = append(poss, word)
}
}
todo := [][]string{{a}}
for len(todo) > 0 {
curr := todo[0]
todo = todo[1:]
var next []string
for _, word := range poss {
if oneAway(word, curr[len(curr)-1]) {
next = append(next, word)
}
}
if contains(next, b) {
curr = append(curr, b)
fmt.Println(strings.Join(curr, " -> "))
return
}
for i := len(poss) - 1; i >= 0; i-- {
if contains(next, poss[i]) {
copy(poss[i:], poss[i+1:])
poss[len(poss)-1] = ""
poss = poss[:len(poss)-1]
}
}
for _, s := range next {
temp := make([]string, len(curr))
copy(temp, curr)
temp = append(temp, s)
todo = append(todo, temp)
}
}
fmt.Println(a, "into", b, "cannot be done.")
}
func main() {
b, err := ioutil.ReadFile("unixdict.txt")
if err != nil {
log.Fatal("Error reading file")
}
bwords := bytes.Fields(b)
words := make([]string, len(bwords))
for i, bword := range bwords {
words[i] = string(bword)
}
pairs := [][]string{
{"boy", "man"},
{"girl", "lady"},
{"john", "jane"},
{"child", "adult"},
}
for _, pair := range pairs {
wordLadder(words, pair[0], pair[1])
}
}
- Output:
boy -> bay -> ban -> man girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady john -> cohn -> conn -> cone -> cane -> jane child into adult cannot be done.
Haskell
Breadth-first search
The function first expands a ball around the starting word in the space of possible words, until the ball surface touches the goal (if ever). After that it performs depth-first path-finding from the goal back to the center.
import System.IO (readFile)
import Control.Monad (foldM)
import Data.List (intercalate)
import qualified Data.Set as S
distance :: String -> String -> Int
distance s1 s2 = length $ filter not $ zipWith (==) s1 s2
wordLadders :: [String] -> String -> String -> [[String]]
wordLadders dict start end
| length start /= length end = []
| otherwise = [wordSpace] >>= expandFrom start >>= shrinkFrom end
where
wordSpace = S.fromList $ filter ((length start ==) . length) dict
expandFrom s = go [[s]]
where
go (h:t) d
| S.null d || S.null f = []
| end `S.member` f = [h:t]
| otherwise = go (S.elems f:h:t) (d S.\\ f)
where
f = foldr (\w -> S.union (S.filter (oneStepAway w) d)) mempty h
shrinkFrom = scanM (filter . oneStepAway)
oneStepAway x = (1 ==) . distance x
scanM f x = fmap snd . foldM g (x,[x])
where g (b, r) a = (\x -> (x, x:r)) <$> f b a
wordLadder :: [String] -> String -> String -> [String]
wordLadder d s e = case wordLadders d s e of
[] -> []
h:_ -> h
showChain [] = putStrLn "No chain"
showChain ch = putStrLn $ intercalate " -> " ch
main = do
dict <- lines <$> readFile "unixdict.txt"
showChain $ wordLadder dict "boy" "man"
showChain $ wordLadder dict "girl" "lady"
showChain $ wordLadder dict "john" "jane"
showChain $ wordLadder dict "alien" "drool"
showChain $ wordLadder dict "child" "adult"
λ> lines <$> readFile "unixdict.txt" >>= print . wordLadders "boy" "man" [["boy","bay","ban","man"],["boy","bon","ban","man"],["boy","bay","may","man"]] λ> lines <$> readFile "unixdict.txt" >>= print . wordLadders "girl" "lady" [["girl","gill","gall","gale","gaze","laze","lazy","lady"]] λ> lines <$> readFile "unixdict.txt" >>= print . wordLadders "child" "adult" [] λ> main boy -> bay -> ban -> man girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady john -> cohn -> conn -> cone -> cane -> jane alien -> alden -> alder -> alter -> aster -> ester -> eater -> bater -> bator -> baton -> baron -> boron -> moron -> moran -> moral -> morel -> monel -> money -> monty -> month -> mouth -> south -> sooth -> sloth -> slosh -> slash -> flash -> flask -> flank -> blank -> bland -> blend -> bleed -> breed -> bread -> tread -> triad -> trial -> trill -> drill -> droll -> drool No chain
Two-sided breadth-first search
Performs searching from both ends. This solution is much faster for cases with no chains, and for for short chains. In case of long chains looses its' efficiency.
wordLadders2 :: String -> String -> [String] -> [[String]]
wordLadders2 start end dict
| length start /= length end = []
| otherwise = pure wordSpace >>= expand start end >>= shrink end
where
wordSpace = S.fromList $ filter ((length start ==) . length) dict
expand s e d = tail . map S.elems <$> go [S.singleton s] [S.singleton e] d
where
go (hs:ts) (he:te) d
| S.null d || S.null fs || S.null fe = []
| not $ S.null f1 = [reverse (f1:te) ++ hs:ts]
| not $ S.null f2 = [reverse (he:te) ++ f2:ts]
| not $ S.null f3 = [reverse (he:te) ++ f3:hs:ts]
| otherwise = go (fs:hs:ts) (fe:he:te) (d S.\\ hs S.\\ he)
where
fs = front hs
fe = front he
f1 = fs `S.intersection` he
f2 = fe `S.intersection` hs
f3 = fs `S.intersection` fe
front = S.foldr (\w -> S.union (S.filter (oneStepAway w) d)) mempty
shrink = scanM (findM . oneStepAway)
oneStepAway x = (1 ==) . distance x
scanM f x = fmap snd . foldM g (x,[x])
where g (b, r) a = (\x -> (x, x:r)) <$> f b a
findM p = msum . map (\x -> if p x then pure x else mzero)
Using A*-search
See A*_search_algorithm#Haskell
import AStar (findPath, Graph(..))
import qualified Data.Map as M
distance :: String -> String -> Int
distance s1 s2 = length $ filter not $ zipWith (==) s1 s2
wordLadder :: [String] -> String -> String -> [String]
wordLadder dict start end = findPath g distance start end
where
short_dict = filter ((length start ==) . length) dict
g = Graph $ \w -> M.fromList [ (x, 1)
| x <- short_dict
, distance w x == 1 ]
λ> main boy -> bay -> ban -> man girl -> gird -> bird -> bard -> lard -> lark -> lack -> lacy -> lady john -> cohn -> conn -> cone -> cane -> jane alien -> alden -> alder -> alter -> aster -> ester -> eater -> bater -> bator -> baton -> baron -> boron -> moron -> moran -> moral -> morel -> monel -> money -> monty -> month -> mouth -> south -> sooth -> sloth -> slosh -> slash -> flash -> flask -> flank -> blank -> bland -> blend -> bleed -> breed -> bread -> tread -> triad -> trial -> trill -> drill -> droll -> drool No chain
Works much faster when compiled.
J
Here we use a double ended breadth first search (starting from each end). This tends to give us several options where they meet in the middle, so we pick a shortest example from those.
extend=: {{
j=. {:y
l=. <:{:$m
<y,"1 0 I.l=m+/ .="1 j{m
}}
wlad=: {{
l=. #x assert. l=#y
words=. >(#~ l=#@>) cutLF fread 'unixdict.txt'
ix=. ,:words i.x assert. ix<#words
iy=. ,:words i.y assert. iy<#words
while. -. 1 e. ix e.&, iy do.
if. 0 e. ix,&# iy do. EMPTY return. end.
ix=. ; words extend"1 ix
if. -. 1 e. ix e.&, iy do.
iy=. ; words extend"1 iy
end.
end.
iy=. |."1 iy
r=. ix,&,iy
for_jk.(ix,&#iy)#:I.,ix +./@e."1/ iy do.
ixj=. ({.jk){ix
iyk=. ({:jk){iy
for_c. ixj ([-.-.) iyk do.
path=. (ixj{.~ixj i.c) , iyk}.~ iyk i.c
if. path <&# r do. r=. path end.
end.
end.
}.,' ',.r{words
}}
Task examples:
'boy' wlad 'man'
boy bay ban man
'girl' wlad 'lady'
girl gill gall gale gaze laze lazy lady
'john' wlad 'jane'
john cohn conn cone cane jane
'child' wlad 'adult'
'cat' wlad 'dog'
cat cot cog dog
'lead' wlad 'gold'
lead load goad gold
'white' wlad 'black'
white whine chine chink clink blink blank black
'bubble' wlad 'tickle'
bubble babble gabble garble gargle gaggle giggle jiggle jingle tingle tinkle tickle
Java
import java.io.IOException;
import java.nio.file.Files;
import java.nio.file.Path;
import java.util.ArrayList;
import java.util.HashMap;
import java.util.HashSet;
import java.util.List;
import java.util.Map;
import java.util.PriorityQueue;
import java.util.Set;
import java.util.stream.IntStream;
public class WordLadder {
private static int distance(String s1, String s2) {
assert s1.length() == s2.length();
return (int) IntStream.range(0, s1.length())
.filter(i -> s1.charAt(i) != s2.charAt(i))
.count();
}
private static void wordLadder(Map<Integer, Set<String>> words, String fw, String tw) {
wordLadder(words, fw, tw, 8);
}
private static void wordLadder(Map<Integer, Set<String>> words, String fw, String tw, int limit) {
if (fw.length() != tw.length()) {
throw new IllegalArgumentException("From word and to word must have the same length");
}
Set<String> ws = words.get(fw.length());
if (ws.contains(fw)) {
List<String> primeList = new ArrayList<>();
primeList.add(fw);
PriorityQueue<List<String>> queue = new PriorityQueue<>((chain1, chain2) -> {
int cmp1 = Integer.compare(chain1.size(), chain2.size());
if (cmp1 == 0) {
String last1 = chain1.get(chain1.size() - 1);
int d1 = distance(last1, tw);
String last2 = chain2.get(chain2.size() - 1);
int d2 = distance(last2, tw);
return Integer.compare(d1, d2);
}
return cmp1;
});
queue.add(primeList);
while (queue.size() > 0) {
List<String> curr = queue.remove();
if (curr.size() > limit) {
continue;
}
String last = curr.get(curr.size() - 1);
for (String word : ws) {
if (distance(last, word) == 1) {
if (word.equals(tw)) {
curr.add(word);
System.out.println(String.join(" -> ", curr));
return;
}
if (!curr.contains(word)) {
List<String> cp = new ArrayList<>(curr);
cp.add(word);
queue.add(cp);
}
}
}
}
}
System.err.printf("Cannot turn `%s` into `%s`%n", fw, tw);
}
public static void main(String[] args) throws IOException {
Map<Integer, Set<String>> words = new HashMap<>();
for (String line : Files.readAllLines(Path.of("unixdict.txt"))) {
Set<String> wl = words.computeIfAbsent(line.length(), HashSet::new);
wl.add(line);
}
wordLadder(words, "boy", "man");
wordLadder(words, "girl", "lady");
wordLadder(words, "john", "jane");
wordLadder(words, "child", "adult");
wordLadder(words, "cat", "dog");
wordLadder(words, "lead", "gold");
wordLadder(words, "white", "black");
wordLadder(words, "bubble", "tickle", 12);
}
}
- Output:
boy -> bay -> may -> man girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady john -> cohn -> conn -> cone -> cane -> jane Cannot turn `child` into `adult` cat -> cot -> dot -> dog lead -> load -> goad -> gold white -> whine -> chine -> chink -> clink -> blink -> blank -> black bubble -> babble -> gabble -> garble -> gargle -> gaggle -> waggle -> wangle -> tangle -> tingle -> tinkle -> tickle
Faster alternative
import java.io.*;
import java.util.*;
public class WordLadder {
public static void main(String[] args) {
try {
Map<Integer, List<String>> words = new HashMap<>();
try (BufferedReader reader = new BufferedReader(new FileReader("unixdict.txt"))) {
String line;
while ((line = reader.readLine()) != null)
words.computeIfAbsent(line.length(), k -> new ArrayList<String>()).add(line);
}
wordLadder(words, "boy", "man");
wordLadder(words, "girl", "lady");
wordLadder(words, "john", "jane");
wordLadder(words, "child", "adult");
wordLadder(words, "cat", "dog");
wordLadder(words, "lead", "gold");
wordLadder(words, "white", "black");
wordLadder(words, "bubble", "tickle");
} catch (Exception e) {
e.printStackTrace();
}
}
// Returns true if strings s1 and s2 differ by one character.
private static boolean oneAway(String s1, String s2) {
if (s1.length() != s2.length())
return false;
boolean result = false;
for (int i = 0, n = s1.length(); i != n; ++i) {
if (s1.charAt(i) != s2.charAt(i)) {
if (result)
return false;
result = true;
}
}
return result;
}
// If possible, print the shortest chain of single-character modifications that
// leads from "from" to "to", with each intermediate step being a valid word.
// This is an application of breadth-first search.
private static void wordLadder(Map<Integer, List<String>> words, String from, String to) {
List<String> w = words.get(from.length());
if (w != null) {
Deque<String> poss = new ArrayDeque<>(w);
Deque<String> f = new ArrayDeque<String>();
f.add(from);
Deque<Deque<String>> queue = new ArrayDeque<>();
queue.add(f);
while (!queue.isEmpty()) {
Deque<String> curr = queue.poll();
for (Iterator<String> i = poss.iterator(); i.hasNext(); ) {
String str = i.next();
if (!oneAway(str, curr.getLast()))
continue;
if (to.equals(str)) {
curr.add(to);
System.out.println(String.join(" -> ", curr));
return;
}
Deque<String> temp = new ArrayDeque<>(curr);
temp.add(str);
queue.add(temp);
i.remove();
}
}
}
System.out.printf("%s into %s cannot be done.\n", from, to);
}
}
- Output:
boy -> bay -> ban -> man girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady john -> cohn -> conn -> cone -> cane -> jane child into adult cannot be done. cat -> cot -> cog -> dog lead -> load -> goad -> gold white -> whine -> chine -> chink -> clink -> blink -> blank -> black bubble -> babble -> gabble -> garble -> gargle -> gaggle -> giggle -> jiggle -> jingle -> tingle -> tinkle -> tickle
jq
Works with gojq, the Go implementation of jq
def count(stream): reduce stream as $i (0; .+1);
def words: [inputs]; # one way to read the word list
def oneAway($a; $b):
($a|explode) as $ax
| ($b|explode) as $bx
| 1 == count(range(0; $a|length) | select($ax[.] != $bx[.]));
# input: the word list
def wordLadder($a; $b):
($a|length) as $len
| { poss: map(select(length == $len)), # the relevant words
todo: [[$a]] # possible chains
}
| until ( ((.todo|length) == 0) or .solution;
.curr = .todo[0]
| .todo |= .[1:]
| .curr[-1] as $c
| (.poss | map(select( oneAway(.; $c) ))) as $next
| if ($b | IN($next[]))
then .curr += [$b]
| .solution = (.curr|join(" -> "))
else .poss = (.poss - $next)
| .curr as $curr
| .todo = (reduce range(0; $next|length) as $i (.todo;
. + [$curr + [$next[$i] ]] ))
end )
| if .solution then .solution
else "There is no ladder from \($a) to \($b)."
end ;
def pairs:
["boy", "man"],
["girl", "lady"],
["john", "jane"],
["child", "adult"],
["word", "play"]
;
words
| pairs as $p
| wordLadder($p[0]; $p[1])
- Output:
Invocation: jq -nr -R -f word-ladder.jq unixdict.txt
boy -> bay -> ban -> man girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady john -> cohn -> conn -> cone -> cane -> jane There is no ladder from child to adult. word -> ford -> form -> foam -> flam -> clam -> clay -> play
Julia
const dict = Set(split(read("unixdict.txt", String), r"\s+"))
function targeted_mutations(str::AbstractString, target::AbstractString)
working, tried = [[str]], Set{String}()
while all(a -> a[end] != target, working)
newworking = Vector{Vector{String}}()
for arr in working
s = arr[end]
push!(tried, s)
for j in 1:length(s), c in 'a':'z'
w = s[1:j-1] * c * s[j+1:end]
if w in dict && !(w in tried)
push!(newworking, [arr; w])
end
end
end
isempty(newworking) && return [["This cannot be done."]]
working = newworking
end
return filter(a -> a[end] == target, working)
end
println("boy to man: ", targeted_mutations("boy", "man"))
println("girl to lady: ", targeted_mutations("girl", "lady"))
println("john to jane: ", targeted_mutations("john", "jane"))
println("child to adult: ", targeted_mutations("child", "adult"))
- Output:
boy to man: [["boy", "bay", "may", "man"], ["boy", "bay", "ban", "man"], ["boy", "bon", "ban", "man"]] girl to lady: [["girl", "gill", "gall", "gale", "gaze", "laze", "lazy", "lady"]] john to jane: [["john", "cohn", "conn", "cone", "cane", "jane"]] child to adult: [["This cannot be done."]]
Mathematica / Wolfram Language
db=DeleteDuplicates[RemoveDiacritics[ToLowerCase[Select[DictionaryLookup[],StringLength/*EqualTo[3]]]]];
sel=Select[Subsets[db,{2}],HammingDistance[#[[1]],#[[2]]]==1&];
g=Graph[db,UndirectedEdge@@@sel];
FindShortestPath[g,"boy","man"]
db=DeleteDuplicates[RemoveDiacritics[ToLowerCase[Select[DictionaryLookup[],StringLength/*EqualTo[4]]]]];
sel=Select[Subsets[db,{2}],HammingDistance[#[[1]],#[[2]]]==1&];
g=Graph[db,UndirectedEdge@@@sel];
FindShortestPath[g,"girl","lady"]
FindShortestPath[g,"john","jane"]
db=DeleteDuplicates[RemoveDiacritics[ToLowerCase[Select[DictionaryLookup[],StringLength/*EqualTo[5]]]]];
sel=Select[Subsets[db,{2}],HammingDistance[#[[1]],#[[2]]]==1&];
g=Graph[db,UndirectedEdge@@@sel];
FindShortestPath[g,"child","adult"]
- Output:
{"boy", "bay", "ban", "man"} {"girl", "gill", "gall", "gals", "gads", "lads", "lady"} {"john", "join", "jain", "main", "mann", "mane", "jane"} {}
Nim
import sets, strformat, strutils
func isOneAway(word1, word2: string): bool =
## Return true if "word1" and "word2" has only one letter of difference.
for i in 0..word1.high:
if word1[i] != word2[i]:
if result: return false # More than one letter of difference.
else: result = true # One letter of difference, for now.
var words: array[1..22, HashSet[string]] # Set of words sorted by length.
for word in "unixdict.txt".lines:
words[word.len].incl word
proc path(start, target: string): seq[string] =
## Return a path from "start" to "target" or an empty list
## if there is no possible path.
let lg = start.len
doAssert target.len == lg, "Source and destination must have same length."
doAssert start in words[lg], "Source must exist in the dictionary."
doAssert target in words[lg], "Destination must exist in the dictionary."
var currPaths = @[@[start]] # Current list of paths found.
var pool = words[lg] # List of possible words to use.
while true:
var newPaths: seq[seq[string]] # Next list of paths.
var added: HashSet[string] # Set of words added during the round.
for candidate in pool:
for path in currPaths:
if candidate.isOneAway(path[^1]):
let newPath = path & candidate
if candidate == target:
# Found a path.
return newPath
else:
# Not the target. Add a new path.
newPaths.add newPath
added.incl candidate
break
if newPaths.len == 0: break # No path.
currPaths = move(newPaths) # Update list of paths.
pool.excl added # Remove added words from pool.
when isMainModule:
for (start, target) in [("boy", "man"), ("girl", "lady"), ("john", "jane"),
("child", "adult"), ("cat", "dog"), ("lead", "gold"),
("white", "black"), ("bubble", "tickle")]:
let path = path(start, target)
if path.len == 0:
echo &"No path from “{start}” to “{target}”."
else:
echo path.join(" → ")
- Output:
boy → bon → ban → man girl → gill → gall → gale → gaze → laze → lazy → lady john → cohn → conn → cone → cane → jane No path from “child” to “adult”. cat → cot → cog → dog lead → load → goad → gold white → whine → chine → chink → clink → clank → blank → black bubble → babble → gabble → garble → gargle → gaggle → waggle → wangle → tangle → tingle → tinkle → tickle
Perl
Direct translation
use strict;
use warnings;
my %dict;
open my $handle, '<', 'unixdict.txt';
while (my $word = <$handle>) {
chomp($word);
my $len = length $word;
if (exists $dict{$len}) {
push @{ $dict{ $len } }, $word;
} else {
my @words = ( $word );
$dict{$len} = \@words;
}
}
close $handle;
sub distance {
my $w1 = shift;
my $w2 = shift;
my $dist = 0;
for my $i (0 .. length($w1) - 1) {
my $c1 = substr($w1, $i, 1);
my $c2 = substr($w2, $i, 1);
if (not ($c1 eq $c2)) {
$dist++;
}
}
return $dist;
}
sub contains {
my $aref = shift;
my $needle = shift;
for my $v (@$aref) {
if ($v eq $needle) {
return 1;
}
}
return 0;
}
sub word_ladder {
my $fw = shift;
my $tw = shift;
if (exists $dict{length $fw}) {
my @poss = @{ $dict{length $fw} };
my @queue = ([$fw]);
while (scalar @queue > 0) {
my $curr_ref = shift @queue;
my $last = $curr_ref->[-1];
my @next;
for my $word (@poss) {
if (distance($last, $word) == 1) {
push @next, $word;
}
}
if (contains(\@next, $tw)) {
push @$curr_ref, $tw;
print join (' -> ', @$curr_ref), "\n";
return;
}
for my $word (@next) {
for my $i (0 .. scalar @poss - 1) {
if ($word eq $poss[$i]) {
splice @poss, $i, 1;
last;
}
}
}
for my $word (@next) {
my @temp = @$curr_ref;
push @temp, $word;
push @queue, \@temp;
}
}
}
print STDERR "Cannot change $fw into $tw\n";
}
word_ladder('boy', 'man');
word_ladder('girl', 'lady');
word_ladder('john', 'jane');
word_ladder('child', 'adult');
word_ladder('cat', 'dog');
word_ladder('lead', 'gold');
word_ladder('white', 'black');
word_ladder('bubble', 'tickle');
- Output:
boy -> bay -> ban -> man girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady john -> cohn -> conn -> cone -> cane -> jane Cannot change child into adult cat -> cot -> cog -> dog lead -> load -> goad -> gold white -> whine -> chine -> chink -> clink -> blink -> blank -> black bubble -> babble -> gabble -> garble -> gargle -> gaggle -> giggle -> jiggle -> jingle -> tingle -> tinkle -> tickle
Idiomatic version
Exactly the same algorithm, written in a more Perl-ish style. Is this better, or worse? Maybe both. Interestingly, runs 1/3-rd faster.
use strict;
use warnings;
use feature 'say';
my %dict;
open my $handle, '<', 'ref/unixdict.txt';
while (my $word = <$handle>) {
chomp $word;
my $l = length $word;
if ($dict{$l}) { push @{ $dict{$l} }, $word }
else { $dict{$l} = \@{[$word]} }
}
close $handle;
sub distance {
my($w1,$w2) = @_;
my $d;
substr($w1, $_, 1) eq substr($w2, $_, 1) or $d++ for 0 .. length($w1) - 1;
return $d // 0;
}
sub contains {
my($aref,$needle) = @_;
$needle eq $_ and return 1 for @$aref;
return 0;
}
sub word_ladder {
my($fw,$tw) = @_;
say 'Nothing like that in dictionary.' and return unless $dict{length $fw};
my @poss = @{ $dict{length $fw} };
my @queue = [$fw];
while (@queue) {
my $curr_ref = shift @queue;
my $last = $curr_ref->[-1];
my @next;
distance($last, $_) == 1 and push @next, $_ for @poss;
push(@$curr_ref, $tw) and say join ' -> ', @$curr_ref and return if contains \@next, $tw;
for my $word (@next) {
$word eq $poss[$_] and splice(@poss, $_, 1) and last for 0 .. @poss - 1;
}
push @queue, \@{[@{$curr_ref}, $_]} for @next;
}
say "Cannot change $fw into $tw";
}
word_ladder(split) for 'boy man', 'girl lady', 'john jane', 'child adult';
Same style output.
Phix
with javascript_semantics sequence words = unix_dict() function right_length(string word, integer l) return length(word)=l end function function one_away(string a, b) return sum(sq_ne(a,b))=1 end function function dca(sequence s, n) return append(deep_copy(s),n) end function procedure word_ladder(string a, b) sequence poss = filter(words,right_length,length(a)), todo = {{a}}, curr -- aka todo[1], word chain starting from a while length(todo) do {curr,todo} = {todo[1],todo[2..$]} sequence next = filter(poss,one_away,curr[$]) if find(b,next) then printf(1,"%s\n",{join(append(deep_copy(curr),b),"->")}) return end if poss = filter(poss,"out",next) todo &= apply(true,dca,{{curr},next}) end while printf(1,"%s into %s cannot be done\n",{a,b}) end procedure word_ladder("boy","man") word_ladder("girl","lady") word_ladder("john","jane") word_ladder("child","adult")
Aside: an initial poss = filter(poss,"out",{a}) might be prudent, but would only prevent a single next:={} step, at about the same cost as the initial filter anyway.
- Output:
boy->bay->ban->man girl->gill->gall->gale->gaze->laze->lazy->lady john->cohn->conn->cone->cane->jane child into adult cannot be done
Python
The function cache is not part of the algorithm but avoid re-download and map re-computing at each re-run.
import os,sys,zlib,urllib.request
def h ( str,x=9 ):
for c in str :
x = ( x*33 + ord( c )) & 0xffffffffff
return x
def cache ( func,*param ):
n = 'cache_%x.bin'%abs( h( repr( param )))
try : return eval( zlib.decompress( open( n,'rb' ).read()))
except : pass
s = func( *param )
open( n,'wb' ).write( zlib.compress( bytes( repr( s ),'ascii' )))
return s
dico_url = 'https://raw.githubusercontent.com/quinnj/Rosetta-Julia/master/unixdict.txt'
read_url = lambda url : urllib.request.urlopen( url ).read()
load_dico = lambda url : tuple( cache( read_url,url ).split( b'\n'))
isnext = lambda w1,w2 : len( w1 ) == len( w2 ) and len( list( filter( lambda l : l[0]!=l[1] , zip( w1,w2 )))) == 1
def build_map ( words ):
map = [(w.decode('ascii'),[]) for w in words]
for i1,(w1,n1) in enumerate( map ):
for i2,(w2,n2) in enumerate( map[i1+1:],i1+1 ):
if isnext( w1,w2 ):
n1.append( i2 )
n2.append( i1 )
return map
def find_path ( words,w1,w2 ):
i = [w[0] for w in words].index( w1 )
front,done,res = [i],{i:-1},[]
while front :
i = front.pop(0)
word,next = words[i]
for n in next :
if n in done : continue
done[n] = i
if words[n][0] == w2 :
while n >= 0 :
res = [words[n][0]] + res
n = done[n]
return ' '.join( res )
front.append( n )
return '%s can not be turned into %s'%( w1,w2 )
for w in ('boy man','girl lady','john jane','alien drool','child adult'):
print( find_path( cache( build_map,load_dico( dico_url )),*w.split()))
- Output:
boy bay ban man girl gill gall gale gaze laze lazy lady john cohn conn cone cane jane alien alden alder alter aster ester eater bater bator baton baron boron moron moran moral morel monel money monty month mouth south sooth sloth slosh slash flash flask flank blank bland blend bleed breed bread tread triad trial trill drill droll drool child can not be turned into adult
Racket
#lang racket
(define *unixdict* (delay (with-input-from-file "../../data/unixdict.txt"
(compose list->set port->lines))))
(define letters-as-strings (map string (string->list "abcdefghijklmnopqrstuvwxyz")))
(define ((replace-for-c-at-i w i) c)
(string-append (substring w 0 i) c (substring w (add1 i))))
(define (candidates w)
(for*/list (((i w_i) (in-parallel (string-length w) w))
(r (in-value (replace-for-c-at-i w i)))
(c letters-as-strings)
#:unless (char=? w_i (string-ref c 0)))
(r c)))
(define (generate-candidates word.path-hash)
(for*/hash (((w p) word.path-hash)
(w′ (candidates w)))
(values w′ (cons w p))))
(define (hash-filter-keys keep-key? h)
(for/hash (((k v) h) #:when (keep-key? k)) (values k v)))
(define (Word-ladder src dest (words (force *unixdict*)))
(let loop ((edge (hash src null)) (unused (set-remove words src)))
(let ((cands (generate-candidates edge)))
(if (hash-has-key? cands dest)
(reverse (cons dest (hash-ref cands dest)))
(let ((new-edge (hash-filter-keys (curry set-member? unused) cands)))
(if (hash-empty? new-edge)
`(no-path-between ,src ,dest)
(loop new-edge (set-subtract unused (list->set (hash-keys new-edge))))))))))
(module+ main
(Word-ladder "boy" "man")
(Word-ladder "girl" "lady")
(Word-ladder "john" "jane")
(Word-ladder "alien" "drool")
(Word-ladder "child" "adult"))
- Output:
'("boy" "bay" "may" "man") '("girl" "gill" "gall" "gale" "gaze" "laze" "lazy" "lady") '("john" "cohn" "conn" "cone" "cane" "jane") '("alien" "alden" "alder" "alter" "aster" "ester" "eater" "bater" "bator" "baton" "baron" "boron" "moron" "moran" "moral" "morel" "monel" "money" "monty" "month" "mouth" "south" "sooth" "sloth" "slosh" "slash" "flash" "flask" "flank" "blank" "bland" "blend" "bleed" "breed" "bread" "tread" "triad" "trial" "trill" "drill" "droll" "drool") '(no-path-between "child" "adult")
Raku
constant %dict = 'unixdict.txt'.IO.lines
.classify(*.chars)
.map({ .key => .value.Set });
sub word_ladder ( Str $from, Str $to ) {
die if $from.chars != $to.chars;
my $sized_dict = %dict{$from.chars};
my @workqueue = (($from,),);
my $used = ($from => True).SetHash;
while @workqueue {
my @new_q;
for @workqueue -> @words {
my $last_word = @words.tail;
my @new_tails = gather for 'a' .. 'z' -> $replacement_letter {
for ^$last_word.chars -> $i {
my $new_word = $last_word;
$new_word.substr-rw($i, 1) = $replacement_letter;
next unless $new_word ∈ $sized_dict
and not $new_word ∈ $used;
take $new_word;
$used{$new_word} = True;
return |@words, $new_word if $new_word eq $to;
}
}
push @new_q, ( |@words, $_ ) for @new_tails;
}
@workqueue = @new_q;
}
}
for <boy man>, <girl lady>, <john jane>, <child adult> -> ($from, $to) {
say word_ladder($from, $to)
// "$from into $to cannot be done";
}
- Output:
(boy bay may man) (girl gill gall gale gaze laze lazy lady) (john cohn conn cone cane jane) child into adult cannot be done
Refal
This program needs to be run with refal -l48 to allocate enough memory for it to run.
$ENTRY Go {
, <ReadFile 1 'unixdict.txt'>: e.Dict
= <DisplayLadder (e.Dict) ('boy') ('man')>
<DisplayLadder (e.Dict) ('girl') ('lady')>
<DisplayLadder (e.Dict) ('john') ('jane')>
<DisplayLadder (e.Dict) ('child') ('adult')>;
};
DisplayLadder {
(e.Dict) (e.From) (e.To),
e.From ' -> ' e.To ': ': e.Header,
<Ladder (e.Dict) (e.From) (e.To)>: {
Impossible = <Prout e.Header 'impossible'>;
Result e.Words = <Prout e.Header <Join ('->') e.Words>>;
};
};
Join {
(e.Join) = ;
(e.Join) (e.Word) = e.Word;
(e.Join) (e.Word) e.Words = e.Word e.Join <Join (e.Join) e.Words>;
};
ReadFile {
s.Chan e.File =
<Open 'r' s.Chan e.File>
<ReadFile (s.Chan)>;
(s.Chan), <Get s.Chan>: {
0 = ;
e.Line = (e.Line) <ReadFile (s.Chan)>;
};
};
Filter {
(e.Fn) = ;
(e.Fn) t.Item e.Items, <Mu e.Fn t.Item>: {
True = t.Item <Filter (e.Fn) e.Items>;
False = <Filter (e.Fn) e.Items>;
};
};
SameLen {
(e.Word1) (e.Word2),
<Lenw e.Word1>: s.Len e.Word1,
<Lenw e.Word2>: s.Len e.Word2 = True;
(e.Word1) (e.Word2) = False;
};
Diffs {
() () = 0;
(s.X e.Word1) (s.X e.Word2) = <Diffs (e.Word1) (e.Word2)>;
(s.X e.Word1) (s.Y e.Word2) = <+ 1 <Diffs (e.Word1) (e.Word2)>>;
};
OneDiff {
t.Word1 t.Word2, <Diffs t.Word1 t.Word2>: {
1 = True;
s.Diffs = False;
};
};
Ladder {
(e.Dict) t.From t.To,
<Filter (SameLen t.From) e.Dict>: e.Dict2 =
<Ladder2 ((t.From)) (e.Dict2) t.To>;
};
Ladder2 {
(e.Ladders) (e.Dict) t.To,
e.Ladders: e.X (e.Words t.To) e.Y = Result e.Words t.To;
(e.Ladders) () t.To = Impossible;
() (e.Dict) t.To = Impossible;
((e.Ladder) e.Ladders) (e.Dict) t.To,
e.Ladder: e.1 t.Last,
<Filter (OneDiff t.Last) e.Dict>: e.NextWords,
<RemoveAll (e.NextWords) e.Dict>: e.NextDict,
<AddAll (e.Ladder) e.NextWords>: e.NextLadders
= <Ladder2 (e.Ladders e.NextLadders) (e.NextDict) t.To>;
};
RemoveAll {
(e.Remove) = ;
(e.Remove) t.Word e.Words, e.Remove: {
e.X t.Word e.Y = <RemoveAll (e.Remove) e.Words>;
e.Remove = t.Word <RemoveAll (e.Remove) e.Words>;
};
};
AddAll {
(e.Ladder) = ;
(e.Ladder) t.Word e.Words =
(e.Ladder t.Word) <AddAll (e.Ladder) e.Words>;
};
- Output:
boy -> man: boy->bay->ban->man girl -> lady: girl->gill->gall->gale->gaze->laze->lazy->lady john -> jane: john->cohn->conn->cone->cane->jane child -> adult: impossible
REXX
This REXX entry does a little more error checking.
It also assumes that the dictionary file is in mixed case as well as the words entered on the CL.
To treat the dictionary and input words as caseless, all words are translated to lowercase.
Programming note: this REXX program uses the lower BIF which Regina has).
If your REXX doesn't support that BIF, here is an equivalent function:
lower: procedure; parse arg a; @= 'abcdefghijklmnopqrstuvwxyz'; @u= @; upper @u
return translate(a, @, @u)
/*REXX program finds words (within an identified dict.) to solve a word ladder puzzle.*/
parse arg base targ iFID . /*obtain optional arguments from the CL*/
if base=='' | base=="," then base= 'boy' /*Not specified? Then use the default.*/
if targ=='' | targ=="," then targ= 'man' /* " " " " " " */
if iFID=='' | iFID=="," then iFID='unixdict.txt' /* " " " " " " */
abc= 'abcdefghijklmnopqrstuvwxyz' /*the lowercase (Latin) alphabet. */
abcU= abc; upper abcU /* " uppercase " " */
base= lower(base); targ= lower(targ) /*lowercase the BASE and also the TARG.*/
L= length(base) /*length of the BASE (in characters). */
if L<2 then call err 'base word is too small or missing' /*oops, too small*/
if length(targ)\==L then call msg , "target word isn't the same length as the base word"
call letters /*assign letters, faster than SUBSTR. */
#= 0 /*# of words whose length matches BASE.*/
@.= /*default value of any dictionary word.*/
do recs=0 while lines(iFID)\==0 /*read each word in the file (word=X).*/
x= lower(strip( linein( iFID) ) ) /*pick off a word from the input line. */
if length(x)\==L then iterate /*Word not correct length? Then skip. */
#= # + 1; @.x= 1 /*bump # words with length L; semaphore*/
end /*recs*/ /* [↑] semaphore name is uppercased. */
!.= 0
say copies('─', 30) recs "words in the dictionary file: " iFID
say copies('─', 30) # "words in the dictionary file of length: " L
say copies('─', 30) ' base word is: ' base
say copies('─', 30) 'target word is: ' targ
rung= targ
$= base
do f=1 for m; call look; if result\=='' then leave /*Found? Quit.*/
end /*f*/
say
if f>m then call msg 'no word ladder solution possible for ' base " ──► " targ
do f-2; $= base; !.= 0 /*process all the rungs that were found*/
do forever; call look; if result\=='' then leave /*Found? Quit.*/
end /*forever*/
end /*f-2*/
call show words(rung)
exit 0 /*stick a fork in it, we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
msg: say; if arg()==2 then say '***error*** ' arg(2); else say arg(1); say; exit 13
show: say 'a solution: ' base; do j=1 to arg(1); say left('',12) word(rung,j); end; return
letters: do m=1 for length(abc); a.m= substr(abc, m, 1); end; return
/*──────────────────────────────────────────────────────────────────────────────────────*/
look: procedure expose @. !. a. $ abc base L rung targ search; rungs= word(rung, 1)
$$=; rung#= words(rungs)
do i=1 for words($); y= word($, i); !.y= 1
do k=1 for L
do n=1 for 26; z= overlay(a.n, y, k) /*change a letter*/
if @.z=='' then iterate /*Is this not a word? Then skip it. */
if !.z then iterate /* " " a repeat? " " " */
if z==rungs then rung= y rung /*prepend a word to the rung list. */
if z==rungs & rung#>1 then return z /*short─circuit. */
if z==targ then return z
$$= $$ z /*append a possible ladder word to $$*/
end /*n*/
end /*k*/
end /*i*/
$= $$; return ''
- output when using the default inputs:
────────────────────────────── 25104 words in the dictionary file: unixdict.txt ────────────────────────────── 796 words in the dictionary file of length: 3 ────────────────────────────── base word is: boy ────────────────────────────── target word is: man a solution: boy bay may man
- output when using the inputs of: girl lady
────────────────────────────── 25104 words in the dictionary file: unixdict.txt ────────────────────────────── 2187 words in the dictionary file of length: 4 ────────────────────────────── base word is: girl ────────────────────────────── target word is: lady a solution: girl gill gall gale gaze laze lazy lady
- output when using the inputs of: john jane
────────────────────────────── 25104 words in the dictionary file: unixdict.txt ────────────────────────────── 2187 words in the dictionary file of length: 4 ────────────────────────────── base word is: john ────────────────────────────── target word is: jane a solution: john cohn conn cone cane jane
- output when using the inputs of: child adult
────────────────────────────── 25104 words in the dictionary file: unixdict.txt ────────────────────────────── 3161 words in the dictionary file of length: 5 ────────────────────────────── base word is: child ────────────────────────────── target word is: adult no word ladder solution possible for child ──► adult
Ruby
require "set"
Words = File.open("unixdict.txt").read.split("\n").
group_by { |w| w.length }.map { |k, v| [k, Set.new(v)] }.
to_h
def word_ladder(from, to)
raise "Length mismatch" unless from.length == to.length
sized_words = Words[from.length]
work_queue = [[from]]
used = Set.new [from]
while work_queue.length > 0
new_q = []
work_queue.each do |words|
last_word = words[-1]
new_tails = Enumerator.new do |enum|
("a".."z").each do |replacement_letter|
last_word.length.times do |i|
new_word = last_word.clone
new_word[i] = replacement_letter
next unless sized_words.include? new_word and
not used.include? new_word
enum.yield new_word
used.add new_word
return words + [new_word] if new_word == to
end
end
end
new_tails.each do |t|
new_q.push(words + [t])
end
end
work_queue = new_q
end
end
[%w<boy man>, %w<girl lady>, %w<john jane>, %w<child adult>].each do |from, to|
if ladder = word_ladder(from, to)
puts ladder.join " → "
else
puts "#{from} into #{to} cannot be done"
end
end
- Output:
boy → bay → may → man girl → gill → gall → gale → gaze → laze → lazy → lady john → cohn → conn → cone → cane → jane child into adult cannot be done
SETL
program word_ladder;
dict := read_dictionary("unixdict.txt");
testpairs := [['boy', 'man'], ['girl', 'lady'], ['john', 'jane'], ['child', 'adult']];
loop for [fromWord, toWord] in testpairs do
l := ladder(dict, fromWord, toWord);
if l = om then
print(fromWord, '->', toWord, 'impossible');
else
print(fromWord, '->', toWord, l);
end if;
end loop;
proc ladder(dict, fromWord, toWord);
dict := {word : word in dict | #word = #fromWord};
ladders := [[fromWord]];
dict less:= fromWord;
loop while ladders /= [] do
l fromb ladders;
next := {word : word in onediff(dict, l(#l))};
dict -:= next;
nextls := [l + [word] : word in next];
if exists l in nextls | l(#l) = toWord then
return l;
end if;
ladders +:= nextls;
end loop;
return om;
end proc;
proc onediff(rw dict, word);
return {other : other in dict | #other = #word and diffs(word, other) = 1};
end proc;
proc diffs(word1, word2);
return +/[if word1(i) = word2(i) then 0 else 1 end : i in [1..#word1]];
end proc;
proc read_dictionary(file);
dictfile := open(file, 'r');
dict := {getline(dictfile) : until eof(dictfile)};
close(dictfile);
return dict;
end proc;
end program;
- Output:
boy -> man [boy bay ban man] girl -> lady [girl gill gall gale gaze laze lazy lady] john -> jane [john cohn conn cone cane jane] child -> adult impossible
Swift
import Foundation
func oneAway(string1: [Character], string2: [Character]) -> Bool {
if string1.count != string2.count {
return false
}
var result = false
var i = 0
while i < string1.count {
if string1[i] != string2[i] {
if result {
return false
}
result = true
}
i += 1
}
return result
}
func wordLadder(words: [[Character]], from: String, to: String) {
let fromCh = Array(from)
let toCh = Array(to)
var poss = words.filter{$0.count == fromCh.count}
var queue: [[[Character]]] = [[fromCh]]
while !queue.isEmpty {
var curr = queue[0]
let last = curr[curr.count - 1]
queue.removeFirst()
let next = poss.filter{oneAway(string1: $0, string2: last)}
if next.contains(toCh) {
curr.append(toCh)
print(curr.map{String($0)}.joined(separator: " -> "))
return
}
poss.removeAll(where: {next.contains($0)})
for str in next {
var temp = curr
temp.append(str)
queue.append(temp)
}
}
print("\(from) into \(to) cannot be done.")
}
do {
let words = try String(contentsOfFile: "unixdict.txt", encoding: String.Encoding.ascii)
.components(separatedBy: "\n")
.filter{!$0.isEmpty}
.map{Array($0)}
wordLadder(words: words, from: "man", to: "boy")
wordLadder(words: words, from: "girl", to: "lady")
wordLadder(words: words, from: "john", to: "jane")
wordLadder(words: words, from: "child", to: "adult")
wordLadder(words: words, from: "cat", to: "dog")
wordLadder(words: words, from: "lead", to: "gold")
wordLadder(words: words, from: "white", to: "black")
wordLadder(words: words, from: "bubble", to: "tickle")
} catch {
print(error.localizedDescription)
}
- Output:
man -> ban -> bay -> boy girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady john -> cohn -> conn -> cone -> cane -> jane child into adult cannot be done. cat -> cot -> cog -> dog lead -> load -> goad -> gold white -> whine -> chine -> chink -> clink -> blink -> blank -> black bubble -> babble -> gabble -> garble -> gargle -> gaggle -> giggle -> jiggle -> jingle -> tingle -> tinkle -> tickle
Wren
import "io" for File
import "./sort" for Find
var words = File.read("unixdict.txt").trim().split("\n")
var oneAway = Fn.new { |a, b|
var sum = 0
for (i in 0...a.count) if (a[i] != b[i]) sum = sum + 1
return sum == 1
}
var wordLadder = Fn.new { |a, b|
var l = a.count
var poss = words.where { |w| w.count == l }.toList
var todo = [[a]]
while (todo.count > 0) {
var curr = todo[0]
todo = todo[1..-1]
var next = poss.where { |w| oneAway.call(w, curr[-1]) }.toList
if (Find.first(next, b) != -1) {
curr.add(b)
System.print(curr.join(" -> "))
return
}
poss = poss.where { |p| !next.contains(p) }.toList
for (i in 0...next.count) {
var temp = curr.toList
temp.add(next[i])
todo.add(temp)
}
}
System.print("%(a) into %(b) cannot be done.")
}
var pairs = [
["boy", "man"],
["girl", "lady"],
["john", "jane"],
["child", "adult"]
]
for (pair in pairs) wordLadder.call(pair[0], pair[1])
- Output:
boy -> bay -> ban -> man girl -> gill -> gall -> gale -> gaze -> laze -> lazy -> lady john -> cohn -> conn -> cone -> cane -> jane child into adult cannot be done.