Option Base 1
Public Enum attr
    Colour = 1
    Nationality
    Beverage
    Smoke
    Pet
End Enum
Public Enum Drinks_
    Beer = 1
    Coffee
    Milk
    Tea
    Water
End Enum
Public Enum nations
    Danish = 1
    English
    German
    Norwegian
    Swedish
End Enum
Public Enum colors
    Blue = 1
    Green
    Red
    White
    Yellow
End Enum
Public Enum tobaccos
    Blend = 1
    BlueMaster
    Dunhill
    PallMall
    Prince
End Enum
Public Enum animals
    Bird = 1
    Cat
    Dog
    Horse
    Zebra
End Enum
Public permutation As New Collection
Public perm(5) As Variant
Const factorial5 = 120
Public Colours As Variant, Nationalities As Variant, Drinks As Variant, Smokes As Variant, Pets As Variant

Private Sub generate(n As Integer, A As Variant)
    If n = 1 Then
        permutation.Add A
    Else
        For i = 1 To n
            generate n - 1, A
            If n Mod 2 = 0 Then
                tmp = A(i)
                A(i) = A(n)
                A(n) = tmp
            Else
                tmp = A(1)
                A(1) = A(n)
                A(n) = tmp
            End If
        Next i
    End If
End Sub

Function house(i As Integer, name As Variant) As Integer
    Dim x As Integer
    For x = 1 To 5
        If perm(i)(x) = name Then
            house = x
            Exit For
        End If
    Next x
End Function

Function left_of(h1 As Integer, h2 As Integer) As Boolean
    left_of = (h1 - h2) = -1
End Function

Function next_to(h1 As Integer, h2 As Integer) As Boolean
    next_to = Abs(h1 - h2) = 1
End Function

Private Sub print_house(i As Integer)
    Debug.Print i & ": "; Colours(perm(Colour)(i)), Nationalities(perm(Nationality)(i)), _
        Drinks(perm(Beverage)(i)), Smokes(perm(Smoke)(i)), Pets(perm(Pet)(i))
End Sub
Public Sub Zebra_puzzle()
    Colours = [{"blue","green","red","white","yellow"}]
    Nationalities = [{"Dane","English","German","Norwegian","Swede"}]
    Drinks = [{"beer","coffee","milk","tea","water"}]
    Smokes = [{"Blend","Blue Master","Dunhill","Pall Mall","Prince"}]
    Pets = [{"birds","cats","dog","horse","zebra"}]
    Dim solperms As New Collection
    Dim solutions As Integer
    Dim b(5) As Integer, i As Integer
    For i = 1 To 5: b(i) = i: Next i
    'There are five houses.
    generate 5, b
    For c = 1 To factorial5
        perm(Colour) = permutation(c)
        'The green house is immediately to the left of the white house.
        If left_of(house(Colour, Green), house(Colour, White)) Then
            For n = 1 To factorial5
                perm(Nationality) = permutation(n)
                'The Norwegian lives in the first house.
                'The English man lives in the red house.
                'The Norwegian lives next to the blue house.
                If house(Nationality, Norwegian) = 1 _
                    And house(Nationality, English) = house(Colour, Red) _
                    And next_to(house(Nationality, Norwegian), house(Colour, Blue)) Then
                    For d = 1 To factorial5
                        perm(Beverage) = permutation(d)
                        'The Dane drinks tea.
                        'They drink coffee in the green house.
                        'In the middle house they drink milk.
                        If house(Nationality, Danish) = house(Beverage, Tea) _
                            And house(Beverage, Coffee) = house(Colour, Green) _
                            And house(Beverage, Milk) = 3 Then
                            For s = 1 To factorial5
                                perm(Smoke) = permutation(s)
                                'In the yellow house they smoke Dunhill.
                                'The German smokes Prince.
                                'The man who smokes Blue Master drinks beer.
                                'They Drink water in a house next to the house where they smoke Blend.
                                If house(Colour, Yellow) = house(Smoke, Dunhill) _
                                    And house(Nationality, German) = house(Smoke, Prince) _
                                    And house(Smoke, BlueMaster) = house(Beverage, Beer) _
                                    And next_to(house(Beverage, Water), house(Smoke, Blend)) Then
                                    For p = 1 To factorial5
                                        perm(Pet) = permutation(p)
                                        'The Swede has a dog.
                                        'The man who smokes Pall Mall has birds.
                                        'The man who smokes Blend lives in the house next to the house with cats.
                                        'In a house next to the house where they have a horse, they smoke Dunhill.
                                        If house(Nationality, Swedish) = house(Pet, Dog) _
                                            And house(Smoke, PallMall) = house(Pet, Bird) _
                                            And next_to(house(Smoke, Blend), house(Pet, Cat)) _
                                            And next_to(house(Pet, Horse), house(Smoke, Dunhill)) Then
                                            For i = 1 To 5
                                                print_house i
                                            Next i
                                            Debug.Print
                                            solutions = solutions + 1
                                            solperms.Add perm
                                        End If
                                    Next p
                                End If
                            Next s
                        End If
                    Next d
                End If
            Next n
        End If
    Next c
    Debug.Print Format(solutions, "@"); " solution" & IIf(solutions > 1, "s", "") & " found"
    For i = 1 To solperms.Count
        For j = 1 To 5
            perm(j) = solperms(i)(j)
        Next j
        Debug.Print "The " & Nationalities(perm(Nationality)(house(Pet, Zebra))) & " owns the Zebra"
    Next i
End Sub


(ql:quickload :cl-ppcre)
(defvar txt
"
 xxxx    xxxx   x    x  x    x   xxxx   x    x       x      x   xxxx   xxxxx
x    x  x    x  xx  xx  xx  xx  x    x  xx   x       x         x    x  x    x
x       x    x  x xx x  x xx x  x    x  x x  x       x      x  xxx     x    x
x       x    x  x    x  x    x  x    x  x  x x       x      x     xxx  xxxxx
x    x  x    x  x    x  x    x  x    x  x   xx       x      x  x    x  x
 xxxx    xxxx   x    x  x    x   xxxx   x    x       xxxxx  x   xxxx   x
"
)
(princ (cl-ppcre:regex-replace-all " " (cl-ppcre:regex-replace-all "x" txt "_/") "  " ))


// Derived from AA3D - ASCII art stereogram generator
// by Jan Hubicka and Thomas Marsh
// (GNU General Public License)
// http://aa-project.sourceforge.net/aa3d/
// http://en.wikipedia.org/wiki/ASCII_stereogram

import std.stdio, std.string, std.random;

immutable image = "
                  111111111111111
                  1111111111111111
                   11111       1111
                   11111        1111
                   11111        1111
                   11111        1111
                   11111        1111
                   11111       1111
                  1111111111111111
                  111111111111111

";

void main() {
    enum int width = 50;
    immutable text = "DLanguage";
    enum int skip = 12;

    char[65536 / 2] data;

    foreach (y, row; image.splitLines()) {
        immutable int shift = uniform(0, int.max);
        bool l = false;

        foreach (x; 0 .. width) {
            int s;
            if (!l && x > skip) {
                s = (x < row.length) ? row[x] : '\n';
                if (s == ' ') {
                    s = 0;
                } else if (s == '\n') {
                    s = 0;
                    l = true;
                } else if (s >= '0' && s <= '9') {
                    s = '0' - s;
                } else
                    s = -2;
            } else
                s = 0;

            s += skip;
            s = x - s;
            s = (s < 0) ? text[(x + shift) % text.length] : data[s];
            data[x] = cast(char)s;
            write(data[x]);
        }

        writeln();
    }
}


type HouseSet = []House
struct House {
    n Nationality
    c Colour
    a Animal
    d Drink
    s Smoke
}

// Define the possible values
enum Nationality {
    english = 0
    swede
    dane
    norwegian
    german
}
enum Colour {
    red = 0
    green
    white
    yellow
    blue
}
enum Animal {
    dog = 0
    birds
    cats
    horse
    zebra
}
enum Drink {
    tea = 0
    coffee
    milk
    beer
    water
}
enum Smoke {
    pall_mall = 0
    dunhill
    blend
    blue_master
    prince
}

// And how to print them

const nationalities = [Nationality.english, Nationality.swede, Nationality.dane, Nationality.norwegian, Nationality.german]
const colours = [Colour.red, Colour.green, Colour.white, Colour.yellow, Colour.blue]
const animals = [Animal.dog, Animal.birds, Animal.cats, Animal.horse, Animal.zebra]
const drinks = [Drink.tea, Drink.coffee, Drink.milk, Drink.beer, Drink.water]
const smokes = [Smoke.pall_mall, Smoke.dunhill, Smoke.blend, Smoke.blue_master, Smoke.prince]

fn (h House) str() string {
        return "${h.n:-9}  ${h.c:-6}  ${h.a:-5}  ${h.d:-6}  $h.s"
}
fn (hs HouseSet) str() string {
        mut lines := []string{len: 0, cap: 5}
        for i, h in hs {
                s := "$i  $h"
                lines << s
        }
        return lines.join("\n")
}

// Simple brute force solution

fn simple_brute_force() (int, HouseSet) {
        mut v := []House{}
        for n in nationalities {
                for c in colours {
                        for a in animals {
                                for d in drinks {
                                        for s in smokes {
                                                h := House{
                                                        n: n,
                                                        c: c,
                                                        a: a,
                                                        d: d,
                                                        s: s,
                                                }
                                                if !h.valid() {
                                                        continue
                                                }
                                                v << h
                                        }
                                }
                        }
                }
        }
        n := v.len
        println("Generated $n valid houses")

        mut combos := 0
        mut first := 0
        mut valid := 0
        mut valid_set := []House{}
        for a := 0; a < n; a++ {
            if v[a].n != Nationality.norwegian { // Condition 10:
                continue
            }
            for b := 0; b < n; b++ {
                if b == a {
                    continue
                }
                if v[b].any_dups(v[a]) {
                    continue
                }
                for c := 0; c < n; c++ {
                        if c == b || c == a {
                            continue
                        }
                        if v[c].d != Drink.milk { // Condition 9:
                            continue
                        }
                        if v[c].any_dups(v[b], v[a]) {
                            continue
                        }
                        for d := 0; d < n; d++ {
                                if d == c || d == b || d == a {
                                    continue
                                }
                                if v[d].any_dups(v[c], v[b], v[a]) {
                                    continue
                                }
                                for e := 0; e < n; e++ {
                                    if e == d || e == c || e == b || e == a {
                                        continue
                                    }
                                    if v[e].any_dups(v[d], v[c], v[b], v[a]) {
                                        continue
                                    }
                                    combos++
                                    set := HouseSet([v[a], v[b], v[c], v[d], v[e]])
                                    if set.valid() {
                                        valid++
                                        if valid == 1 {
                                                first = combos
                                        }
                                        valid_set = set
                                        //return set
                                    }
                                }
                        }
                }
            }
        }
        println("Tested $first different combinations of valid houses before finding solution")
        println("Tested $combos different combinations of valid houses in total")
        return valid, valid_set
}

// any_dups returns true if h as any duplicate attributes with any of the specified houses
fn (h House) any_dups(list ...House) bool {
    for b in list {
        if h.n == b.n || h.c == b.c || h.a == b.a || h.d == b.d || h.s == b.s {
            return true
        }
    }
    return false
}

fn (h House) valid() bool {
    // Condition 2:
    if (h.n == Nationality.english && h.c != Colour.red) || (h.n != Nationality.english && h.c == Colour.red) {
        return false
    }
    // Condition 3:
    if (h.n == Nationality.swede && h.a != Animal.dog) || (h.n != Nationality.swede && h.a == Animal.dog) {
        return false
    }
    // Condition 4:
    if (h.n == Nationality.dane && h.d != Drink.tea) || (h.n != Nationality.dane && h.d == Drink.tea ){
        return false
    }
    // Condition 6:
    if (h.c == Colour.green && h.d != Drink.coffee) || (h.c != Colour.green && h.d == Drink.coffee) {
        return false
    }
    // Condition 7:
    if (h.a == Animal.birds && h.s != Smoke.pall_mall) || (h.a != Animal.birds && h.s == Smoke.pall_mall) {
        return false
    }
    // Condition 8:
    if (h.c == Colour.yellow && h.s != Smoke.dunhill) || (h.c != Colour.yellow && h.s == Smoke.dunhill) {
        return false
    }
    // Condition 11:
    if h.a == Animal.cats && h.s == Smoke.blend {
        return false
    }
    // Condition 12:
    if h.a == Animal.horse && h.s == Smoke.dunhill {
        return false
    }
    // Condition 13:
    if (h.d == Drink.beer && h.s != Smoke.blue_master) || (h.d != Drink.beer && h.s == Smoke.blue_master) {
        return false
    }
    // Condition 14:
    if (h.n == Nationality.german && h.s != Smoke.prince) || (h.n != Nationality.german && h.s == Smoke.prince) {
        return false
    }
    // Condition 15:
    if h.n == Nationality.norwegian && h.c == Colour.blue {
        return false
    }
    // Condition 16:
    if h.d == Drink.water && h.s == Smoke.blend {
        return false
    }
    return true
}

fn (hs HouseSet) valid() bool {
    mut ni := map[Nationality]int{}
    mut ci := map[Colour]int{}
    mut ai := map[Animal]int{}
    mut di := map[Drink]int{}
    mut si := map[Smoke]int{}
    for i, h in hs {
            ni[h.n] = i
            ci[h.c] = i
            ai[h.a] = i
            di[h.d] = i
            si[h.s] = i
    }
    // Condition 5:
    if ci[Colour.green]+1 != ci[Colour.white] {
            return false
    }
    // Condition 11:
    if dist(ai[Animal.cats], si[Smoke.blend]) != 1 {
            return false
    }
    // Condition 12:
    if dist(ai[Animal.horse], si[Smoke.dunhill]) != 1 {
            return false
    }
    // Condition 15:
    if dist(ni[Nationality.norwegian], ci[Colour.blue]) != 1 {
            return false
    }
    // Condition 16:
    if dist(di[Drink.water], si[Smoke.blend]) != 1 {
            return false
    }

    // Condition 9: (already tested elsewhere)
    if hs[2].d != Drink.milk {
            return false
    }
    // Condition 10: (already tested elsewhere)
    if hs[0].n != Nationality.norwegian {
            return false
    }
    return true
}

fn dist(a int, b int) int {
    if a > b {
        return a - b
    }
    return b - a
}

fn main() {
    n, sol := simple_brute_force()
    println("$n solution found")
    println(sol)
}


import "/fmt" for Fmt

var colors  = ["Red", "Green", "White", "Yellow", "Blue"]
var nations = ["English", "Swede", "Danish", "Norwegian", "German"]
var animals = ["Dog", "Birds", "Cats", "Horse", "Zebra"]
var drinks  = ["Tea", "Coffee", "Milk", "Beer", "Water"]
var smokes  = ["Pall Mall", "Dunhill", "Blend", "Blue Master", "Prince"]

var p = List.filled(120, null) //  stores all permutations of numbers 0..4
for (i in 0..119) p[i] = List.filled(5, -1)

var nextPerm = Fn.new { |perm|
    var size = perm.count
    var k = -1
    for (i in size-2..0) {
        if (perm[i] < perm[i + 1]) {
            k = i
            break
        }
    }
    if (k == -1) return false  // last permutation
    for (l in size-1..k) {
        if (perm[k] < perm[l]) {
            perm.swap(k, l)
            var m = k + 1
            var n = size - 1
            while (m < n) {
                perm.swap(m, n)
                m = m + 1
                n = n - 1
            }
            break
        }
    }
    return true
}

var check = Fn.new { |a1, a2, v1, v2|
    for (i in 0..4) {
        if (p[a1][i] == v1) return p[a2][i] == v2
    }
    return false
}

var checkLeft = Fn.new { |a1, a2, v1, v2|
    for (i in 0..3) {
        if (p[a1][i] == v1) return p[a2][i + 1] == v2
    }
    return false
}

var checkRight = Fn.new { |a1, a2, v1, v2|
    for (i in 1..4) {
        if (p[a1][i] == v1) return p[a2][i - 1] == v2
    }
    return false
}

var checkAdjacent = Fn.new { |a1, a2, v1, v2|
    return checkLeft.call(a1, a2, v1, v2) || checkRight.call(a1, a2, v1, v2)
}

var printHouses = Fn.new { |c, n, a, d, s|
    var owner = ""
    System.print("House  Color   Nation     Animal  Drink   Smokes")
    System.print("=====  ======  =========  ======  ======  ===========")
    for (i in 0..4) {
        var f = "$3d    $-6s  $-9s  $-6s  $-6s  $-11s"
        var l = [i + 1, colors[p[c][i]], nations[p[n][i]], animals[p[a][i]], drinks[p[d][i]], smokes[p[s][i]]]
        Fmt.lprint(f, l)
        if (animals[p[a][i]] == "Zebra") owner = nations[p[n][i]]
    }
    System.print("\nThe %(owner) owns the Zebra\n")
}

var fillHouses = Fn.new {
    var solutions = 0
    for (c in 0..119) {
        if (!checkLeft.call(c, c, 1, 2)) continue                      // C5 : Green left of white
        for (n in 0..119) {
            if (p[n][0] != 3) continue                                 // C10: Norwegian in First
            if (!check.call(n, c, 0, 0)) continue                      // C2 : English in Red
            if (!checkAdjacent.call(n, c, 3, 4)) continue              // C15: Norwegian next to Blue
            for (a in 0..119) {
                if (!check.call(a, n, 0, 1)) continue                  // C3 : Swede has Dog
                for (d in 0..119) {
                    if (p[d][2] != 2) continue                         // C9 : Middle drinks Milk
                    if (!check.call(d, n, 0, 2)) continue              // C4 : Dane drinks Tea
                    if (!check.call(d, c, 1, 1)) continue              // C6 : Green drinks Coffee
                    for (s in 0..119) {
                        if (!check.call(s, a, 0, 1)) continue          // C7 : Pall Mall has Birds
                        if (!check.call(s, c, 1, 3)) continue          // C8 : Yellow smokes Dunhill
                        if (!check.call(s, d, 3, 3)) continue          // C13: Blue Master drinks Beer
                        if (!check.call(s, n, 4, 4)) continue          // C14: German smokes Prince
                        if (!checkAdjacent.call(s, a, 2, 2)) continue  // C11: Blend next to Cats
                        if (!checkAdjacent.call(s, a, 1, 3)) continue  // C12: Dunhill next to Horse
                        if (!checkAdjacent.call(s, d, 2, 4)) continue  // C16: Blend next to Water
                        solutions = solutions + 1
                        printHouses.call(c, n, a, d, s)
                    }
                }
            }
        }
    }
    return solutions
}

var perm = [0, 1, 2, 3, 4]
for (i in 0..119) {
    for (j in 0..4) p[i][j] = perm[j]
    nextPerm.call(perm)
}
var solutions = fillHouses.call()
var plural = (solutions == 1) ? "" : "s"
System.print("%(solutions) solution%(plural) found")


void main(){
 print("""

 XXX       XX       XXX     XXXX
  X   X    X    X     X    X      X
   X   X    XXXX      XXX        X
    XXX      X    X      X   X      X
  """.replaceAll('X','_/'));
}


var people,drinks,houses,smokes,pets; // lists treated as associated arrays
fcn c2 { people.find(English)==houses.find(Red) }
fcn c3 { people.find(Swede)==pets.find(Dog) }
fcn c4 { people.find(Dane)==drinks.find(Tea) }
fcn c5 { (houses.find(Green) + 1)==houses.find(White) }
fcn c5a{ houses.find(Green)!=4 }	// deduced constraint (from c5)
fcn c5b{ houses.find(White)!=0 }	// deduced constraint (from c5)
fcn c6 { drinks.find(Coffee)==houses.find(Green) }
fcn c7 { smokes.find(PallMall)==pets.find(Bird) }
fcn c8 { houses.find(Yellow)==smokes.find(Dunhill) }
fcn c9 { drinks[2]==Milk }  // 0,1,2,3,4
fcn c10{ people[0]==Norwegian }
fcn c11{ (smokes.find(Blend) - pets.find(Cat)).abs()==1 }
fcn c12{ (pets.find(Horse) - smokes.find(Dunhill)).abs()==1 }
fcn c13{ smokes.find(BlueMaster)==drinks.find(Beer) }
fcn c14{ people.find(German)==smokes.find(Prince) }
fcn c15{ (people.find(Norwegian) - houses.find(Blue)).abs()==1 }
fcn c16{ (drinks.find(Water) - smokes.find(Blend)).abs()==1 }
#<<<#//////////////////////////////////////////////////////////////////////
Showing a solution to c2,c5,c10,c15:
	|0	   1       2         3         4
--------+-------------------------------------------
houses:	|Yellow    Blue    Red       Green     White
people:	|Norwegian Dane    English   German    Swede
#<<<#//////////////////////////////////////////////////////////////////////

const Blue =0,Green     =1,Red    =2,White    =3,Yellow=4,
      Dane =0,English   =1,German =2,Norwegian=3,Swede =4,
      Beer =0,Coffee    =1,Milk   =2,Tea      =3,Water =4,
      Blend=0,BlueMaster=1,Dunhill=2,PallMall =3,Prince=4,
      Bird =0,Cat       =1,Dog    =2,Horse    =3,Zebra =4;
perm5:=T(0,1,2,3,4) : Utils.Helpers.permute(_); // 120 sets

constraints:=T(c2,c3,c4,c5,c5a,c5b,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15,c16);
constraints1:=T(c2,c5,c10,c15); // houses,people: 12 solutions
constraints2:=T(c4,c6,c9);      // houses,people,drinks: down to 8 solutions
foreach _houses,_people in (perm5,perm5){ houses,people=_houses,_people;
   if(not constraints1.runNFilter(False)){ // all constraints are True
      foreach _drinks in (perm5){ drinks=_drinks;
	 if(not constraints2.runNFilter(False)){
	    foreach _smokes,_pets in (perm5,perm5){ smokes,pets=_smokes,_pets;
	       if(not constraints.runNFilter(False)) printSolution();
	    }// smokes,pets
	 }
      } // drinks
   } // houses,people
}
fcn printSolution{
   var titles=T("Houses:","People:","Drinks:","Smokes:","Pets:"),
       names=T(
          T("Blue", "Green",      "Red",    "White",    "Yellow",),
	  T("Dane", "English",    "German", "Norwegian","Swede",),
	  T("Beer", "Coffee",     "Milk",   "Tea",      "Water",),
	  T("Blend","Blue Master","Dunhill","Pall Mall","Prince",),
	  T("Bird", "Cat",        "Dog",    "Horse",    "Zebra",) ),
   ;
   fmt:=("%-7s " + "%-11s "*5).fmt;
   foreach list,title,names in (T(houses,people,drinks,smokes,pets)
	   .zip(titles,names))
      { println(list.apply(names.get):fmt(title,_.xplode())) }
}


let make2Darray (picture : string list) =
    let maxY = picture.Length
    let maxX = picture |> List.maxBy String.length |> String.length
    let arr =
        (fun y x ->
            if picture.[y].Length <= x then ' '
            else picture.[y].[x])
        |> Array2D.init maxY maxX
    (arr, maxY, maxX)

let (cube, cy, cx) =
    [
        @"///\";
        @"\\\/";
    ]
    |> make2Darray

let (p2, my, mx) =
    [
        "*****";
        "*         *    * ";
        "*         *    * ";
        "*       **********";
        "****      *    * ";
        "*         *    * ";
        "*       **********";
        "*         *    * ";
        "*         *    * ";
    ]
    |> make2Darray

let a2 = Array2D.create (cy/2 * (my+1)) (cx/2 * mx + my) ' '

let imax = my * (cy/2)
for y in 0 .. Array2D.length1 p2 - 1 do
    for x in 0 .. Array2D.length2 p2 - 1 do
        let indent = Math.Max(imax - y, 0)
        if p2.[y, x] = '*' then Array2D.blit cube 0 0 a2 y (indent+x) cy cx

Array2D.iteri (fun y x c ->
    if x = 0 then printfn ""
    printf "%c" c) a2


package main

import (
    "fmt"
    "strings"
)

var lean = font{
    height:  5,
    slant:   1,
    spacing: 2,
    m: map[rune][]string{
        'G': []string{
            `  _/_/_/`,
            `_/      `,
            `_/  _/_/`,
            `_/    _/`,
            `  _/_/_/`,
        },
        'o': []string{
            `        `,
            `  _/_/  `,
            `_/    _/`,
            `_/    _/`,
            `  _/_/  `,
        },
    }}

var smallKeyboard = font{
    height:  4,
    slant:   0,
    spacing: -1,
    m: map[rune][]string{
        'G': []string{
            ` ____ `,
            `||G ||`,
            `||__||`,
            `|/__\|`,
        },
        'o': []string{
            ` ____ `,
            `||o ||`,
            `||__||`,
            `|/__\|`,
        },
    }}

type font struct {
    height  int
    slant   int
    spacing int
    m       map[rune][]string
}

func render(s string, f font) string {
    rows := make([]string, f.height)
    if f.slant != 0 {
        start := 0
        if f.slant > 0 {
            start = f.height
        }
        for i := range rows {
            rows[i] = strings.Repeat(" ", (start-i)*f.slant)
        }
    }
    if f.spacing >= 0 {
        spacing := strings.Repeat(" ", f.spacing)
        for j, c := range s {
            for i, r := range f.m[c] {
                if j > 0 {
                    r = spacing + r
                }
                rows[i] += r
            }
        }
    } else {
        overlap := -f.spacing
        for j, c := range s {
            for i, r := range f.m[c] {
                if j > 0 {
                    r = r[overlap:]
                }
                rows[i] += r
            }
        }
    }
    return strings.Join(rows, "\n")
}

func main() {
    fmt.Println(render("Go", lean))
    fmt.Println(render("Go", smallKeyboard))
}


println(replace(raw"""
  xxxxx
     x            x
     x            x   x
     x   x  x   x
     x   x  x   x   x    xxx
     x   x  x   x   x   x   x
 x  x   x  x   x   x   x   xx
  xx     xx    x   x    x x xx
 """, "x" => "_/"))


locs = Position[
   ImageData[Binarize[Rasterize["Mathematica", ImageSize -> 150]]], 0];
Print[StringRiffle[
   StringJoin /@
    ReplacePart[
     ReplacePart[
      ConstantArray[
       " ", {Max[locs[[All, 1]]] + 1, Max[locs[[All, 2]]] + 1}],
      locs -> "\\"], Map[# + 1 &, locs, {2}] -> "#"], "\n"]];


/* NetRexx */
options replace format comments java crossref symbols nobinary

txt = '';
x = 0
x = x + 1; txt[0] = x; txt[x] = '   *    *            *****'
x = x + 1; txt[0] = x; txt[x] = '   **   *        *   *    *'
x = x + 1; txt[0] = x; txt[x] = '   * *  *  ***  ***  *    *  ***  *   * *   *'
x = x + 1; txt[0] = x; txt[x] = '   *  * * *   *  *   *****  *   *  * *   * *'
x = x + 1; txt[0] = x; txt[x] = '   *   ** *****  *   *  *   *****   *     *'
x = x + 1; txt[0] = x; txt[x] = '   *    * *      *   *   *  *      * *   * *'
x = x + 1; txt[0] = x; txt[x] = '   *    *  ***    ** *    *  ***  *   * *   *'
x = x + 1; txt[0] = x; txt[x] = ''

_top = '_TOP'
_bot = '_BOT'
txt = Banner3D(txt, isTrue())
loop ll = 1 to txt[0]
  say txt[ll, _top]
  say txt[ll, _bot]
  end ll

return

method Banner3D(txt, slope = '') public static

  select
    when slope = isTrue() then nop
    when slope = isFalse() then nop
    otherwise do
      if slope = '' then slope = isFalse()
                    else slope = isTrue()
      end
    end

  _top = '_TOP'
  _bot = '_BOT'
  loop ll = 1 to txt[0]
    txt[ll, _top] = txt[ll]
    txt[ll, _bot] = txt[ll]
    txt[ll, _top] = txt[ll, _top].changestr(' ', '   ')
    txt[ll, _bot] = txt[ll, _bot].changestr(' ', '   ')
    txt[ll, _top] = txt[ll, _top].changestr('*', '///')
    txt[ll, _bot] = txt[ll, _bot].changestr('*', '\\\\\\')
    txt[ll, _top] = txt[ll, _top] || ' '
    txt[ll, _bot] = txt[ll, _bot] || ' '
    txt[ll, _top] = txt[ll, _top].changestr('/ ', '/\\')
    txt[ll, _bot] = txt[ll, _bot].changestr('\\ ', '\\/')
    end ll

  if slope then do
    loop li = txt[0] to 1 by -1
      ll = txt[0] - li + 1
      txt[ll, _top] = txt[ll, _top].insert('', 1, li - 1, ' ')
      txt[ll, _bot] = txt[ll, _bot].insert('', 1, li - 1, ' ')
      end li
    end

  return txt

method isTrue public constant binary returns boolean
  return 1 == 1

method isFalse public constant binary returns boolean
  return \isTrue()


program WritePascal;

const
  i64: int64 = 1055120232691680095; (* This defines "Pascal" *)
  cc: array[-1..15] of string = (* Here are all string-constants *)
    ('_______v---',
    '__', '\_', '___', '\__',
    '  ', '  ', '   ', '   ',
    '/ ', '  ', '_/ ', '\/ ',
    ' _', '__', '  _', '  _');
var
  x, y: integer;

begin
  for y := 0 to 7 do
  begin
    Write(StringOfChar(cc[(not y and 1) shl 2][1], 23 - y and 6));
    Write(cc[((i64 shr (y div 2)) and 1) shl 3 + (not y and 1) shl 2 + 2]);
    for x := 0 to 15 do
      Write(cc[((i64 shr ((x and 15) * 4 + y div 2)) and 1) +
        ((i64 shr (((x + 1) and 15) * 4 + y div 2)) and 1) shl 3 +
        (x mod 3) and 2 + (not y and 1) shl 2]);
    writeln(cc[1 + (not y and 1) shl 2] + cc[(not y and 1) shl 3 - 1]);
  end;
end.


#lang racket/gui

;; Get the language name
(define str (cadr (regexp-match #rx"Welcome to (.*?) *v[0-9.]+\n*$" (banner))))

;; Font to use
(define font (make-object font% 12 "MiscFixed" 'decorative 'normal 'bold))
;; (get-face-list) -> get a list of faces to try in the above

;; Calculate the needed size (leave space for a drop-down shadow)
(define-values [W H]
  (let ([bdc (make-object bitmap-dc% (make-object bitmap% 1 1 #t))])
    (call-with-values
        (λ() (send* bdc (set-font font) (get-text-extent str font)))
        (λ(w h _1 _2) (values (+ 2 (inexact->exact (round w)))
                              (+ 2 (inexact->exact (round h))))))))

;; Draw the text
(define bmp (make-bitmap W H #t))
(define dc (send bmp make-dc))
(send* dc (set-font font) (draw-text str 2 0))

;; Grab the pixels as a string, 3d-ed with "/"s
(define scr
  (let* ([size (* W H 4)] [buf (make-bytes size)])
    (send bmp get-argb-pixels 0 0 W H buf)
    (define scr (make-string (* (add1 W) (add1 H)) #\space))
    (for ([i (in-range 0 size 4)] [j (* W H)]
          #:unless (zero? (bytes-ref buf i)))
      (string-set! scr j #\@)
      (for ([k (list j (+ j W -1))] [c "/."] #:when #t
            [k (list (- k 1) (+ k W) (+ k W -1))]
            #:when (and (< -1 k (string-length scr))
                        (member (string-ref scr k) '(#\space #\.))))
        (string-set! scr k c)))
    scr))

;; Show it, dropping empty lines
(let ([lines (for/list ([y H]) (substring scr (* y W) (* (add1 y) W)))])
  (define (empty? l) (not (regexp-match #rx"[^ ]" l)))
  (for ([line (dropf-right (dropf lines empty?) empty?)])
    (displayln (string-trim line #:left? #f))))


text = <<EOS
####        #
#   #       #
#   #       #
####  #  #  ###  #   #
# #   #  #  #  #  # #
#  #  #  #  #  #   #
#   #  ###  ###   #
                 #
                #
EOS

def banner3D_1(text, shift=-1)
  txt = text.each_line.map{|line| line.gsub('#','__/').gsub(' ','   ')}
  offset = Array.new(txt.size){|i| " " * shift.abs * i}
  offset.reverse! if shift < 0
  puts offset.zip(txt).map(&:join)
end
banner3D_1(text)

puts
# Other display:
def banner3D_2(text, shift=-2)
  txt = text.each_line.map{|line| line.chomp + ' '}
  offset = txt.each_index.map{|i| " " * shift.abs * i}
  offset.reverse! if shift < 0
  txt.each_with_index do |line,i|
    line2 = offset[i] + line.gsub(' ','   ').gsub('#','///').gsub('/ ','/\\')
    puts line2, line2.tr('/\\\\','\\\\/')
  end
end
banner3D_2(text)

puts
# Another display:
def banner3D_3(text)
  txt = text.each_line.map(&:rstrip)
  offset = [*0...txt.size].reverse
  area = Hash.new(' ')
  box = [%w(/ / / \\), %w(\\ \\ \\ /)]
  txt.each_with_index do |line,i|
    line.each_char.with_index do |c,j|
      next if c==' '
      x = offset[i] + 2*j
      box[0].each_with_index{|c,k| area[[x+k,i  ]] = c}
      box[1].each_with_index{|c,k| area[[x+k,i+1]] = c}
    end
  end
  (xmin, xmax), (ymin, ymax) = area.keys.transpose.map(&:minmax)
  puts (ymin..ymax).map{|y| (xmin..xmax).map{|x| area[[x,y]]}.join}
end

banner3D_3 <<EOS
####         #
#   #        #
#   #        #
#   #        #
####   #  #  ####  #     #
# #    #  #  #   #  #   #
#  #   #  #  #   #   # #
#   #  #  #  #   #    #
#    #  ###  ####    #
                    #
                   #
EOS


def ASCII3D = {

val name = """
               *
   **  **  *   *    *
  *   *   * *  *   * *
  *   *   * *  *   * *
   *  *   ***  *   ***
    * *   * *  *   * *
    * *   * *  *   * *
  **   ** *  * *** * *
                     *
                      *
  """

// Create Array

def getMaxSize(s: String): (Int, Int) = {
  var width = 0
  var height = 0

  val nameArray = s.split("\n")
  height = nameArray.size
  nameArray foreach { i => width = (i.size max width) }

  (width, height)
}

val size = getMaxSize(name)
var arr = Array.fill(size._2 + 1, (size._1 * 3) + (size._2 + 1))(' ')

//
// Map astrisk to 3D cube
//
val cubeTop = """///\""" //"
val cubeBottom = """\\\/""" //"

val nameArray = name.split("\n")

for (j <- (0 until nameArray.size)) {
  for (i <- (0 until nameArray(j).size)) {
    if (nameArray(j)(i) == '*') {
      val indent = nameArray.size - j
      arr(j) = arr(j) patch ((i * 3 + indent), cubeTop, cubeTop.size)
      arr(j + 1) = arr(j + 1) patch ((i * 3 + indent), cubeBottom, cubeBottom.size)
    }
  }
}

//
// Map Array to String
//
var name3D = ""

for (j <- (0 until arr.size)) {
  for (i <- (0 until arr(j).size)) { name3D += arr(j)(i) }
  name3D += "\n"
    }
    name3D
  }

  println(ASCII3D)


$include "seed7_05.s7i";

const array string: name is [] (
    " ***                  * ***** ",
    "*                     *     * ",
    "*      ***   ***   ****     * ",
    "*     *   * *   * *   *    *  ",
    " ***  *   * *   * *   *    *  ",
    "    * ***** ***** *   *   *   ",
    "    * *     *     *   *   *   ",
    "    * *     *     *   *  *    ",
    " ***   ***   ***   ****  *    ");

const proc: main is func
  local
    var integer: index is 0;
    var string: help is "";
    var string: line is "";
    var string: previousLine is "";
    var integer: pos is 0;
  begin
    for index range 1 to length(name) do
      help := replace(name[index], " ", "   ");
      line := "" lpad length(name) - index <&
              replace(replace(help, "*", "///"), "/ ", "/\\");
      if previousLine = "" then
        writeln(line);
      else
        for pos range 1 to length(line) do
          if line[pos] <> ' ' then
            write(line[pos]);
          else
            write(previousLine[pos]);
          end if;
        end for;
        writeln;
      end if;
      previousLine := "" lpad length(name) - index <&
                      replace(replace(help, "*", "\\\\\\"), "\\ ", "\\/");
    end for;
    writeln(previousLine);
  end func;


var text = <<'EOT';

     ***
    *     *     *        **
    *           *       *
    *     *     *  ***  **
     ***  *  **** *   * *
        * * *   * ***** *
        * * *   * *     *
        * * *   * *     *
     ***  *  ****  ***  *
EOT

func banner3D(text, shift=-1) {
    var txt = text.lines.map{|line| line.gsub('*','__/').gsub(' ','   ')};
    var offset = txt.len.of {|i| " " * (shift.abs * i)};
    shift < 0 && offset.reverse!;
    (offset »+« txt).join("\n");
};

say banner3D(text);


SELECT           ' SSS\ ' AS s, ' QQQ\  ' AS q, 'L\   ' AS l  FROM dual
UNION ALL SELECT 'S   \|',      'Q   Q\ ',      'L |  '       FROM dual
UNION ALL SELECT '\SSS  ',      'Q   Q |',      'L |  '       FROM dual
UNION ALL SELECT ' \  S\',      'Q Q Q |',      'L |  '       from dual
union all select ' SSS |',      '\QQQ\\|',      'LLLL\'       from dual
union all select ' \__\/',      ' \_Q_/ ',      '\___\'       from dual
union all select '      ',      '   \\  ',      '     '       from dual;


package require Tcl 8.5

proc mergeLine {upper lower} {
    foreach u [split $upper ""] l [split $lower ""] {
	lappend result [expr {$l in {" " ""} ? $u : $l}]
    }
    return [join $result ""]
}
proc printLines lines {
    set n [llength $lines]
    foreach line $lines {
	set indent [string repeat " " $n]
	lappend upper $indent[string map {"/ " "/\\"} [
		string map {" " "   " "*" "///"} "$line "]]
	lappend lower $indent[string map {"\\ " "\\/"} [
		string map {" " "   " "*" "\\\\\\"} "$line "]]
	incr n -1
    }
    # Now do some line merging to strengthen the visual effect
    set p [string repeat " " [string length [lindex $upper 0]]]
    foreach u $upper l $lower {
	puts [mergeLine $p $u]
	set p $l
    }
    puts $p
}

set lines {
    {*****   *}
    {  *     *}
    {  * *** *}
    {  * *   *}
    {  * *   *}
    {  * *** *}
}
printLines $lines


// Method 1
// r$ = system$("explorer \"http://www.network-science.de/ascii/ascii.php?TEXT=${delegate}&x=23&y=10&FONT=block&RICH=no&FORM=left&STRE=no&WIDT=80&TEXT=Yabasic\"")

// Method 2
// print
// print " _|      _|          _|                            _|            "
// print "   _|  _|    _|_|_|  _|_|_|      _|_|_|    _|_|_|        _|_|_|  "
// print "     _|    _|    _|  _|    _|  _|    _|  _|_|      _|  _|        "
// print "     _|    _|    _|  _|    _|  _|    _|      _|_|  _|  _|        "
// print "     _|      _|_|_|  _|_|_|      _|_|_|  _|_|_|    _|    _|_|_|  "
// print

// Method 3
clear screen

dim d$(5)

d$(0) = "X    X   X   XXXX     X    XXX  X  XXX "
d$(1) = " X  X   X X  X   X   X X  X     X X   X"
d$(2) = "  X    XXXXX XXXX   XXXXX  XXX  X X    "
d$(3) = "  X    X   X X   X  X   X     X X X   X"
d$(4) = "  X    X   X XXXX   X   X XXXX  X  XXX "

long = len(d$(0))

sub write(dx, dy, c$)
	local x, y

	for y = 0 to 4
		for x = 0 to long
			if mid$(d$(y), x, 1) = "X" print at(x + dx, y + dy) c$
		next x
	next y
end sub

write(2, 2, "\\")
write(1, 1, "#")
print


#<<<
"
xxxxxx  x   x  x
    x   x  x   x
  x     x x    x
x       x  x   x
xxxxx   x   x  xxxx
"
#<<<<
.replace(" ","  ").replace("x","_/").println();


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


# 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


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


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


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


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"


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


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


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


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


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


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


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


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


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


lower: procedure;  parse arg a;   @= 'abcdefghijklmnopqrstuvwxyz';    @u= @;    upper @u
                   return translate(a, @, @u)


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


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


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


V GRID =
‘N   D   E
 O   K   G
 E   L   W’

F getwords()
   V words = File(‘unixdict.txt’).read().lowercase().split("\n")
   R words.filter(w -> w.len C 3..9)

F solve(grid, dictionary)
   DefaultDict[Char, Int] gridcount
   L(g) grid
      gridcount[g]++

   F check_word(word)
      DefaultDict[Char, Int] lcount
      L(l) word
         lcount[l]++
      L(l, c) lcount
         I c > @gridcount[l]
            R 1B
      R 0B

   V mid = grid[4]
   R dictionary.filter(word -> @mid C word & [email protected]_word(word))

V chars = GRID.lowercase().split_py().join(‘’)
V found = solve(chars, dictionary' getwords())
print(found.join("\n"))


puts:	equ	9		; CP/M syscall to print string
fopen:	equ	15		; CP/M syscall to open a file
fread:	equ	20		; CP/M syscall to read from file
FCB1:	equ	5Ch		; First FCB (input file)
DTA:	equ	80h		; Disk transfer address
	org	100h
	;;;	Make wheel (2nd argument) lowercase and store it
	lxi	d,DTA+1		; Start of command line arguments
scan:	inr	e		; Scan until we find a space
	rz			; Stop if not found in 128 bytes
	ldax	d
	cpi	' '		; Found it?
	jnz	scan		; If not, try again
	inx	d		; If so, wheel starts 1 byte onwards
	lxi	h,wheel		; Space for wheel
	lxi	b,920h		; B=9 (chars), C=20 (case bit)
whlcpy:	ldax	d		; Get wheel character
	ora	c		; Make lowercase
	mov	m,a		; Store
	inx	d		; Increment both pointers
	inx	h
	dcr	b		; Decrement counter
	jnz	whlcpy		; While not zero, copy next character
	;;;	Open file in FCB1
	mvi	e,FCB1		; D is already 0
	mvi	c,fopen
	call	5		; Returns A=FF on error
	inr	a		; If incrementing A gives zero,
	jz	err		; then print error and stop
	lxi	h,word		; Copy into word
	;;;	Read a 128-byte block from the file
block:	push	h		; Keep word pointer
	lxi	d,FCB1		; Read from file
	mvi	c,fread
	call	5
	pop	h		; Restore word pointer
	dcr	a		; A=1 = EOF
	rz			; If so, stop.
	inr	a		; Otherwise, A<>0 = error
	jnz	err
	lxi	d,DTA		; Start reading at DTA
char:	ldax	d		; Get character
	mov	m,a		; Store in word
	cpi	26		; EOF reached?
	rz			; Then stop
	cpi	10		; End of line reached?
	jz	ckword		; Then we have a full word
	inx	h		; Increment word pointer
nxchar:	inr	e		; Increment DTA pointer (low byte)
	jz	block		; If rollover, get next block
	jmp	char		; Otherwise, handle next character in block
	;;;	Check if current word is valid
ckword:	push	d		; Keep block pointer
	lxi	d,wheel		; Copy the wheel
	lxi	h,wcpy
	mvi	c,9		; 9 characters
cpyw:	ldax	d		; Get character
	mov	m,a		; Store in copy
	inx	h		; Increment pointers
	inx	d
	dcr	c		; Decrement counters
	jnz	cpyw		; Done yet?
	lxi	d,word		; Read from current word
wrdch:	ldax	d		; Get character
	cpi	32		; Check if <32
	jc	wdone		; If so, the word is done
	lxi	h,wcpy		; Check against the wheel letters
	mvi	b,9
wlch:	cmp	m		; Did we find it?
	jz	findch
	inx	h		; If not, try next character in wheel
	dcr	b		; As long as there are characters
	jnz	wlch		; If no match, this word is invalid
wnext:	pop	d		; Restore block pointer
	lxi	h,word		; Start reading new word
	jmp	nxchar		; Continue with character following word
findch:	mvi	m,0		; Found a match - set char to 0
	inx	d		; And look at next character in word
	jmp	wrdch
wdone:	lda	wcpy+4		; Word is done - check if middle char used
	ana	a		; If not, the word is invalid
	jnz	wnext
	lxi	h,wcpy		; See how many characters used
	lxi	b,9		; C=9 (counter), B=0 (used)
whtest:	mov	a,m		; Get wheel character
	ana	a		; Is it zero?
	jnz	$+4		; If not, skip next instr
	inr	b		; If so, count it
	inx	h		; Next wheel character
	dcr	c		; Decrement counter
	jnz	whtest
	mvi	a,2		; At least 3 characters must be used
	cmp	b
	jnc	wnext		; If not, the word is invalid
	xchg			; If so, the word _is_ valid, pointer in HL
	mvi	m,13		; add CR
	inx	h
	mvi	m,10		; and LF
	inx	h
	mvi	m,'$'		; and the CP/M string terminator
	lxi	d,word		; Then print the word
	mvi	c,puts
	call	5
	jmp	wnext
err:	lxi	d,errs		; Print file error
	mvi	c,puts
	jz	5
errs:	db	'File error$'	; Error message
wheel:	ds	9		; Room for wheel
wcpy:	ds	9		; Copy of wheel (to mark characters used)
word:	equ	$		; Room for current word


wordwheel←{
    words←((~∊)∘⎕TC⊆⊢) 80 ¯1⎕MAP ⍵
    match←{
        0=≢⍵:1
        ~(⊃⍵)∊⍺:0
        ⍺[(⍳⍴⍺)~⍺⍳⊃⍵]∇1↓⍵
    }
    middle←(⌈0.5×≢)⊃⊢
    words←((middle ⍺)∊¨words)/words
    words←(⍺∘match¨words)/words
    (⍺⍺≤≢¨words)/words
}


use AppleScript version "2.4"
use framework "Foundation"
use scripting additions

------------------------ WORD WHEEL ----------------------

-- wordWheelMatches :: NSString -> [String] -> String -> String
on wordWheelMatches(lexicon, wordWheelRows)

    set wheelGroups to group(sort(characters of ¬
        concat(wordWheelRows)))

    script isWheelWord
        on |λ|(w)
            script available
                on |λ|(a, b)
                    length of a ≤ length of b
                end |λ|
            end script

            script used
                on |λ|(grp)
                    w contains item 1 of grp
                end |λ|
            end script

            all(my identity, ¬
                zipWith(available, ¬
                    group(sort(characters of w)), ¬
                    filter(used, wheelGroups)))
        end |λ|
    end script

    set matches to filter(isWheelWord, ¬
        filteredLines(wordWheelPreFilter(wordWheelRows), lexicon))

    (length of matches as text) & " matches:" & ¬
        linefeed & linefeed & unlines(matches)
end wordWheelMatches

-- wordWheelPreFilter :: [String] -> String
on wordWheelPreFilter(wordWheelRows)
    set pivot to item 2 of item 2 of wordWheelRows
    set charSet to nub(concat(wordWheelRows))

    "(2 < self.length) and (self contains '" & pivot & "') " & ¬
        "and not (self matches '^.*[^" & charSet & "].*$') "
end wordWheelPreFilter

--------------------------- TEST -------------------------
on run
    set fpWordList to scriptFolder() & "unixdict.txt"
    if doesFileExist(fpWordList) then

        wordWheelMatches(readFile(fpWordList), ¬
            {"nde", "okg", "elw"})

    else
        display dialog "Word list not found in script folder:" & ¬
            linefeed & tab & fpWordList
    end if
end run

----------- GENERIC :: FILTERED LINES FROM FILE ----------

-- doesFileExist :: FilePath -> IO Bool
on doesFileExist(strPath)
    set ca to current application
    set oPath to (ca's NSString's stringWithString:strPath)'s ¬
        stringByStandardizingPath
    set {bln, int} to (ca's NSFileManager's defaultManager's ¬
        fileExistsAtPath:oPath isDirectory:(reference))
    bln and (int ≠ 1)
end doesFileExist

-- filteredLines :: String -> NString -> [a]
on filteredLines(predicateString, s)
    -- A list of lines filtered by an NSPredicate string
    set ca to current application

    set predicate to ca's NSPredicate's predicateWithFormat:predicateString
    set array to ca's NSArray's ¬
        arrayWithArray:(s's componentsSeparatedByString:(linefeed))

    (array's filteredArrayUsingPredicate:(predicate)) as list
end filteredLines

-- readFile :: FilePath -> IO NSString
on readFile(strPath)
    set ca to current application
    set e to reference
    set {s, e} to (ca's NSString's ¬
        stringWithContentsOfFile:((ca's NSString's ¬
            stringWithString:strPath)'s ¬
            stringByStandardizingPath) ¬
            encoding:(ca's NSUTF8StringEncoding) |error|:(e))
    if missing value is e then
        s
    else
        (localizedDescription of e) as string
    end if
end readFile

-- scriptFolder :: () -> IO FilePath
on scriptFolder()
    -- The path of the folder containing this script
    try
        tell application "Finder" to ¬
            POSIX path of ((container of (path to me)) as alias)
    on error
        display dialog "Script file must be saved"
    end try
end scriptFolder

------------------------- GENERIC ------------------------

-- Tuple (,) :: a -> b -> (a, b)
on Tuple(a, b)
    -- Constructor for a pair of values,
    -- possibly of two different types.
    {type:"Tuple", |1|:a, |2|:b, length:2}
end Tuple

-- all :: (a -> Bool) -> [a] -> Bool
on all(p, xs)
    -- True if p holds for every value in xs
    tell mReturn(p)
        set lng to length of xs
        repeat with i from 1 to lng
            if not |λ|(item i of xs, i, xs) then return false
        end repeat
        true
    end tell
end all

-- concat :: [[a]] -> [a]
-- concat :: [String] -> String
on concat(xs)
    set lng to length of xs
    if 0 < lng and string is class of (item 1 of xs) then
        set acc to ""
    else
        set acc to {}
    end if
    repeat with i from 1 to lng
        set acc to acc & item i of xs
    end repeat
    acc
end concat

-- eq (==) :: Eq a => a -> a -> Bool
on eq(a, b)
    a = b
end eq

-- filter :: (a -> Bool) -> [a] -> [a]
on filter(p, xs)
    tell mReturn(p)
        set lst to {}
        set lng to length of xs
        repeat with i from 1 to lng
            set v to item i of xs
            if |λ|(v, i, xs) then set end of lst to v
        end repeat
        if {text, string} contains class of xs then
            lst as text
        else
            lst
        end if
    end tell
end filter

-- foldl :: (a -> b -> a) -> a -> [b] -> a
on foldl(f, startValue, xs)
    tell mReturn(f)
        set v to startValue
        set lng to length of xs
        repeat with i from 1 to lng
            set v to |λ|(v, item i of xs, i, xs)
        end repeat
        return v
    end tell
end foldl

-- group :: Eq a => [a] -> [[a]]
on group(xs)
    script eq
        on |λ|(a, b)
            a = b
        end |λ|
    end script

    groupBy(eq, xs)
end group

-- groupBy :: (a -> a -> Bool) -> [a] -> [[a]]
on groupBy(f, xs)
    -- Typical usage: groupBy(on(eq, f), xs)
    set mf to mReturn(f)

    script enGroup
        on |λ|(a, x)
            if length of (active of a) > 0 then
                set h to item 1 of active of a
            else
                set h to missing value
            end if

            if h is not missing value and mf's |λ|(h, x) then
                {active:(active of a) & {x}, sofar:sofar of a}
            else
                {active:{x}, sofar:(sofar of a) & {active of a}}
            end if
        end |λ|
    end script

    if length of xs > 0 then
        set dct to foldl(enGroup, {active:{item 1 of xs}, sofar:{}}, rest of xs)
        if length of (active of dct) > 0 then
            sofar of dct & {active of dct}
        else
            sofar of dct
        end if
    else
        {}
    end if
end groupBy

-- identity :: a -> a
on identity(x)
    -- The argument unchanged.
    x
end identity

-- length :: [a] -> Int
on |length|(xs)
    set c to class of xs
    if list is c or string is c then
        length of xs
    else
        (2 ^ 29 - 1) -- (maxInt - simple proxy for non-finite)
    end if
end |length|

-- min :: Ord a => a -> a -> a
on min(x, y)
    if y < x then
        y
    else
        x
    end if
end min

-- mReturn :: First-class m => (a -> b) -> m (a -> b)
on mReturn(f)
    -- 2nd class handler function
    -- lifted into 1st class script wrapper.
    if script is class of f then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn

-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
    -- The list obtained by applying f
    -- to each element of xs.
    tell mReturn(f)
        set lng to length of xs
        set lst to {}
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, i, xs)
        end repeat
        return lst
    end tell
end map

-- nub :: [a] -> [a]
on nub(xs)
    nubBy(eq, xs)
end nub

-- nubBy :: (a -> a -> Bool) -> [a] -> [a]
on nubBy(f, xs)
    set g to mReturn(f)'s |λ|

    script notEq
        property fEq : g
        on |λ|(a)
            script
                on |λ|(b)
                    not fEq(a, b)
                end |λ|
            end script
        end |λ|
    end script

    script go
        on |λ|(xs)
            if (length of xs) > 1 then
                set x to item 1 of xs
                {x} & go's |λ|(filter(notEq's |λ|(x), items 2 thru -1 of xs))
            else
                xs
            end if
        end |λ|
    end script

    go's |λ|(xs)
end nubBy

-- sort :: Ord a => [a] -> [a]
on sort(xs)
    ((current application's NSArray's arrayWithArray:xs)'s ¬
        sortedArrayUsingSelector:"compare:") as list
end sort

-- take :: Int -> [a] -> [a]
-- take :: Int -> String -> String
on take(n, xs)
    if 0 < n then
        items 1 thru min(n, length of xs) of xs
    else
        {}
    end if
end take

-- unlines :: [String] -> String
on unlines(xs)
    -- A single string formed by the intercalation
    -- of a list of strings with the newline character.
    set {dlm, my text item delimiters} to ¬
        {my text item delimiters, linefeed}
    set s to xs as text
    set my text item delimiters to dlm
    s
end unlines

-- zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
on zipWith(f, xs, ys)
    set lng to min(|length|(xs), |length|(ys))
    if 1 > lng then return {}
    set xs_ to take(lng, xs) -- Allow for non-finite
    set ys_ to take(lng, ys) -- generators like cycle etc
    set lst to {}
    tell mReturn(f)
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs_, item i of ys_)
        end repeat
        return lst
    end tell
end zipWith


letters := ["N", "D", "E", "O", "K", "G", "E", "L", "W"]

FileRead, wList, % A_Desktop "\unixdict.txt"
result := ""
for word in Word_wheel(wList, letters, 3)
    result .= word "`n"
MsgBox % result
return

Word_wheel(wList, letters, minL){
    oRes := []
    for i, w in StrSplit(wList, "`n", "`r")
    {
        if (StrLen(w) < minL)
            continue
        word := w
        for i, l in letters
            w := StrReplace(w, l,,, 1)
        if InStr(word, letters[5]) && !StrLen(w)
            oRes[word] := true
    }
    return oRes
}


# syntax: GAWK -f WORD_WHEEL.AWK letters unixdict.txt
#         the required letter must be first
#
# example: GAWK -f WORD_WHEEL.AWK Kndeogelw unixdict.txt
#
BEGIN {
    letters = tolower(ARGV[1])
    required = substr(letters,1,1)
    size = 3
    ARGV[1] = ""
}
{   word = tolower($0)
    leng_word = length(word)
    if (word ~ required && leng_word >= size) {
      hits = 0
      for (i=1; i<=leng_word; i++) {
        if (letters ~ substr(word,i,1)) {
          hits++
        }
      }
      if (leng_word == hits && hits >= size) {
        for (i=1; i<=leng_word; i++) {
          c = substr(word,i,1)
          if (gsub(c,"&",word) > gsub(c,"&",letters)) {
            next
          }
        }
        words++
        printf("%s ",word)
      }
    }
}
END {
    printf("\nletters: %s, '%s' required, %d words >= %d characters\n",letters,required,words,size)
    exit(0)
}


10 DEFINT A-Z
20 DATA "ndeokgelw","unixdict.txt"
30 READ WH$, F$
40 OPEN "I",1,F$
50 IF EOF(1) THEN CLOSE 1: END
60 C$ = WH$
70 LINE INPUT #1, W$
80 FOR I=1 TO LEN(W$)
90 FOR J=1 TO LEN(C$)
100 IF MID$(W$,I,1)=MID$(C$,J,1) THEN MID$(C$,J,1)="@": GOTO 120
110 NEXT J: GOTO 50
120 NEXT I
130 IF MID$(C$,(LEN(C$)+1)/2,1)<>"@" GOTO 50
140 C=0: FOR I=1 TO LEN(C$): C=C-(MID$(C$,I,1)="@"): NEXT
150 IF C>=3 THEN PRINT W$,
160 GOTO 50


get "libhdr"

// Read word from selected input
let readword(v) = valof
$(  let ch = ?
    v%0 := 0
    $(  ch := rdch()
        if ch = endstreamch then resultis false
        if ch = '*N' then resultis true
        v%0 := v%0 + 1
        v%(v%0) := ch
    $) repeat
$)

// Test word against wheel
let match(wheel, word) = valof
$(  let wcopy = vec 2+9/BYTESPERWORD
    for i = 0 to wheel%0 do wcopy%i := wheel%i
    for i = 1 to word%0 do
    $(  let idx = ?
        test valof
        $(  for j = 1 to wcopy%0 do
                if word%i = wcopy%j then
                $(  idx := j
                    resultis true
                $)
            resultis false
        $)  then wcopy%idx := 0 // we've used this letter
            else resultis false // word cannot be made
    $)
    resultis
        wcopy%((wcopy%0+1)/2)=0 & // middle letter must be used
        3 <= valof                // at least 3 letters must be used
        $(  let count = 0
            for i = 1 to wcopy%0 do
                if wcopy%i=0 then count := count + 1
            resultis count
        $)
$)

// Test unixdict.txt against ndeokgelw
let start() be
$(  let word = vec 2+64/BYTESPERWORD
    let file = findinput("unixdict.txt")
    let wheel = "ndeokgelw"

    selectinput(file)
    while readword(word) do
        if match(wheel, word) do
            writef("%S*N", word)
    endread()
$)


#include <stdbool.h>
#include <stdio.h>

#define MAX_WORD 80
#define LETTERS 26

bool is_letter(char c) { return c >= 'a' && c <= 'z'; }

int index(char c) { return c - 'a'; }

void word_wheel(const char* letters, char central, int min_length, FILE* dict) {
    int max_count[LETTERS] = { 0 };
    for (const char* p = letters; *p; ++p) {
        char c = *p;
        if (is_letter(c))
            ++max_count[index(c)];
    }
    char word[MAX_WORD + 1] = { 0 };
    while (fgets(word, MAX_WORD, dict)) {
        int count[LETTERS] = { 0 };
        for (const char* p = word; *p; ++p) {
            char c = *p;
            if (c == '\n') {
                if (p >= word + min_length && count[index(central)] > 0)
                    printf("%s", word);
            } else if (is_letter(c)) {
                int i = index(c);
                if (++count[i] > max_count[i]) {
                    break;
                }
            } else {
                break;
            }
        }
    }
}

int main(int argc, char** argv) {
    const char* dict = argc == 2 ? argv[1] : "unixdict.txt";
    FILE* in = fopen(dict, "r");
    if (in == NULL) {
        perror(dict);
        return 1;
    }
    word_wheel("ndeokgelw", 'k', 3, in);
    fclose(in);
    return 0;
}


#include <array>
#include <iostream>
#include <fstream>
#include <map>
#include <string>
#include <vector>
#include <boost/program_options.hpp>

// A multiset specialized for strings consisting of lowercase
// letters ('a' to 'z').
class letterset {
public:
    letterset() {
        count_.fill(0);
    }
    explicit letterset(const std::string& str) {
        count_.fill(0);
        for (char c : str)
            add(c);
    }
    bool contains(const letterset& set) const {
        for (size_t i = 0; i < count_.size(); ++i) {
            if (set.count_[i] > count_[i])
                return false;
        }
        return true;
    }
    unsigned int count(char c) const {
        return count_[index(c)];
    }
    bool is_valid() const {
        return count_[0] == 0;
    }
    void add(char c) {
        ++count_[index(c)];
    }
private:
    static bool is_letter(char c) { return c >= 'a' && c <= 'z'; }
    static int index(char c) { return is_letter(c) ? c - 'a' + 1 : 0; }
    // elements 1..26 contain the number of times each lowercase
    // letter occurs in the word
    // element 0 is the number of other characters in the word
    std::array<unsigned int, 27> count_;
};

template <typename iterator, typename separator>
std::string join(iterator begin, iterator end, separator sep) {
    std::string result;
    if (begin != end) {
        result += *begin++;
        for (; begin != end; ++begin) {
            result += sep;
            result += *begin;
        }
    }
    return result;
}

using dictionary = std::vector<std::pair<std::string, letterset>>;

dictionary load_dictionary(const std::string& filename, int min_length,
                           int max_length) {
    std::ifstream in(filename);
    if (!in)
        throw std::runtime_error("Cannot open file " + filename);
    std::string word;
    dictionary result;
    while (getline(in, word)) {
        if (word.size() < min_length)
            continue;
        if (word.size() > max_length)
            continue;
        letterset set(word);
        if (set.is_valid())
            result.emplace_back(word, set);
    }
    return result;
}

void word_wheel(const dictionary& dict, const std::string& letters,
                char central_letter)  {
    letterset set(letters);
    if (central_letter == 0 && !letters.empty())
        central_letter = letters.at(letters.size()/2);
    std::map<size_t, std::vector<std::string>> words;
    for (const auto& pair : dict) {
        const auto& word = pair.first;
        const auto& subset = pair.second;
        if (subset.count(central_letter) > 0 && set.contains(subset))
            words[word.size()].push_back(word);
    }
    size_t total = 0;
    for (const auto& p : words) {
        const auto& v = p.second;
        auto n = v.size();
        total += n;
        std::cout << "Found " << n << " " << (n == 1 ? "word" : "words")
            << " of length " << p.first << ": "
            << join(v.begin(), v.end(), ", ") << '\n';
    }
    std::cout << "Number of words found: " << total << '\n';
}

void find_max_word_count(const dictionary& dict, int word_length) {
    size_t max_count = 0;
    std::vector<std::pair<std::string, char>> max_words;
    for (const auto& pair : dict) {
        const auto& word = pair.first;
        if (word.size() != word_length)
            continue;
        const auto& set = pair.second;
        dictionary subsets;
        for (const auto& p : dict) {
            if (set.contains(p.second))
                subsets.push_back(p);
        }
        letterset done;
        for (size_t index = 0; index < word_length; ++index) {
            char central_letter = word[index];
            if (done.count(central_letter) > 0)
                continue;
            done.add(central_letter);
            size_t count = 0;
            for (const auto& p : subsets) {
                const auto& subset = p.second;
                if (subset.count(central_letter) > 0)
                    ++count;
            }
            if (count > max_count) {
                max_words.clear();
                max_count = count;
            }
            if (count == max_count)
                max_words.emplace_back(word, central_letter);
        }
    }
    std::cout << "Maximum word count: " << max_count << '\n';
    std::cout << "Words of " << word_length << " letters producing this count:\n";
    for (const auto& pair : max_words)
        std::cout << pair.first << " with central letter " << pair.second << '\n';
}

constexpr const char* option_filename = "filename";
constexpr const char* option_wheel = "wheel";
constexpr const char* option_central = "central";
constexpr const char* option_min_length = "min-length";
constexpr const char* option_part2 = "part2";

int main(int argc, char** argv) {
    const int word_length = 9;
    int min_length = 3;
    std::string letters = "ndeokgelw";
    std::string filename = "unixdict.txt";
    char central_letter = 0;
    bool do_part2 = false;

    namespace po = boost::program_options;
    po::options_description desc("Allowed options");
    desc.add_options()
        (option_filename, po::value<std::string>(), "name of dictionary file")
        (option_wheel, po::value<std::string>(), "word wheel letters")
        (option_central, po::value<char>(), "central letter (defaults to middle letter of word)")
        (option_min_length, po::value<int>(), "minimum word length")
        (option_part2, "include part 2");

    try {
        po::variables_map vm;
        po::store(po::parse_command_line(argc, argv, desc), vm);
        po::notify(vm);

        if (vm.count(option_filename))
            filename = vm[option_filename].as<std::string>();
        if (vm.count(option_wheel))
            letters = vm[option_wheel].as<std::string>();
        if (vm.count(option_central))
            central_letter = vm[option_central].as<char>();
        if (vm.count(option_min_length))
            min_length = vm[option_min_length].as<int>();
        if (vm.count(option_part2))
            do_part2 = true;

        auto dict = load_dictionary(filename, min_length, word_length);
        // part 1
        word_wheel(dict, letters, central_letter);
        // part 2
        if (do_part2) {
            std::cout << '\n';
            find_max_word_count(dict, word_length);
        }
    } catch (const std::exception& ex) {
        std::cerr << ex.what() << '\n';
        return EXIT_FAILURE;
    }
    return EXIT_SUCCESS;
}


program Word_wheel;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  System.Classes;

function IsInvalid(s: string): Boolean;
var
  c: char;
  leters: set of char;
  firstE: Boolean;
begin
  Result := (s.Length < 3) or (s.IndexOf('k') = -1) or (s.Length > 9);
  if not Result then
  begin
    leters := ['d', 'e', 'g', 'k', 'l', 'n', 'o', 'w'];
    firstE := true;
    for c in s do
    begin
      if c in leters then
        if (c = 'e') and (firstE) then
          firstE := false
        else
          Exclude(leters, AnsiChar(c))
      else
        exit(true);
    end;
  end;
end;

var
  dict: TStringList;
  i: Integer;
begin
  dict := TStringList.Create;
  dict.LoadFromFile('unixdict.txt');

  for i := dict.count - 1 downto 0 do
    if IsInvalid(dict[i]) then
      dict.Delete(i);

  Writeln('The following ', dict.Count, ' words are the solutions to the puzzle:');
  Writeln(dict.Text);

  dict.Free;
  readln;
end.


// Word Wheel: Nigel Galloway. May 25th., 2021
let fG k n g=g|>Seq.exists(fun(n,_)->n=k) && g|>Seq.forall(fun(k,g)->Map.containsKey k n && g<=n.[k])
let wW n g=let fG=fG(Seq.item 4 g)(g|>Seq.countBy id|>Map.ofSeq) in seq{use n=System.IO.File.OpenText(n) in while not n.EndOfStream do yield n.ReadLine()}|>Seq.filter(fun n->2<(Seq.length n)&&(Seq.countBy id>>fG)n)
wW "unixdict.txt" "ndeokgelw"|>Seq.iter(printfn "%s")


USING: assocs io.encodings.ascii io.files kernel math
math.statistics prettyprint sequences sorting ;

! Only consider words longer than two letters and words that
! contain elt.
: pare ( elt seq -- new-seq )
    [ [ member? ] keep length 2 > and ] with filter ;

: words ( input-str path -- seq )
    [ [ [email protected] ] keep nth ] [ ascii file-lines pare ] bi* ;

: ?<= ( m n/f -- ? ) dup f = [ nip ] [ <= ] if ;

! Can we make sequence 1 with the elements in sequence 2?
: can-make? ( seq1 seq2 -- ? )
    [ histogram ] [email protected] [ swapd at ?<= ] curry assoc-all? ;

: solve ( input-str path -- seq )
    [ words ] keepd [ can-make? ] curry filter ;

"ndeokgelw" "unixdict.txt" solve [ length ] sort-with .