//////////////////////////////////////////////////////////////////////////////////////////////
//
//  FourWord problem: place predefined letters in a partially filled 
//  4x4 grid, so the grid forms words in all rows and colums.
//
//  For example, place the following letters : 
//
//        a,b,e,l,n,o,p,p,s,t
//
//  into the blank spaces to create four-letter words down and accross.
//
// +---+---+---+---+
// |   | o |   |   |    
// +---+---+---+---+    
// |   |   | l | e |    
// +---+---+---+---+    
// |   |   | a | n |
// +---+---+---+---+
// | l |   |   |   |
// +---+---+---+---+
//
// will result in 
//
// +---+---+---+---+
// | p | o | p | s |    
// +---+---+---+---+    
// | a | b | l | e |    
// +---+---+---+---+    
// | l | o | a | n |
// +---+---+---+---+
// | l | e | n | t |
// +---+---+---+---+
//
//
//////////////////////////////////////////////////////////////////////////////////////////////
//
// In order to solve the puzzle, we need a list of four-letter words. The words 
// themselves are located in another module "FourLetterWords".
//
// This program uses a GUI (Graphical User Interface) via an external module FourWordExt.dll
//
// To run the program, execute the query
//
//      FourWordGUI()
//
//////////////////////////////////////////////////////////////////////////////////////////////

use 'FourLetterWords'   // List of all four letter words 

subr FourWordGUI() iff
    FourWordCreateWindow('F1 FourWord Puzzle Solver',h) &
    FourWordGUISolve(h) 

local AllLines = [0..]->S
local Arrs = ah:[0..3]->AllLines, av:[0..3]->AllLines

local subr FourWordGUISolve(h:<I) iff
    arr :. Arrs & 
    FourWordGetUserValues(h,a1,a2) &        // Get the user suplied letters
    CreateUsedLettersList(a1,0,Nil,l1) &    // l1 = list of initialize letters
    CreateUsedLettersList(a2,0,l1,l2) &     // l2 = list of all 16 letters

    // We have list of 16 letters that must be placed in the grid.
    // Sort the list, this will help later on to avoid duplicate (identical) 
    // solutions. 

    RtlSortAscending(l2,l3) & 

    // Create list/array of all words for each horizontal row.
    all x in lh0 GetWord([a1(0), a1(1), a1(2), a1(3) ],a2,x) end & ah0 = lh0:AllLines & 
    all x in lh1 GetWord([a1(4), a1(5), a1(6), a1(7) ],a2,x) end & ah1 = lh1:AllLines & 
    all x in lh2 GetWord([a1(8), a1(9), a1(10),a1(11)],a2,x) end & ah2 = lh2:AllLines & 
    all x in lh3 GetWord([a1(12),a1(13),a1(14),a1(15)],a2,x) end & ah3 = lh3:AllLines & 

    // Create list/array of all words for each vertical column.
    all x in lv0 GetWord([a1(0), a1(4), a1(8), a1(12)],a2,x) end & av0 = lv0:AllLines & 
    all x in lv1 GetWord([a1(1), a1(5), a1(9), a1(13)],a2,x) end & av1 = lv1:AllLines & 
    all x in lv2 GetWord([a1(2), a1(6), a1(10),a1(14)],a2,x) end & av2 = lv2:AllLines & 
    all x in lv3 GetWord([a1(3), a1(7), a1(11),a1(15)],a2,x) end & av3 = lv3:AllLines & 
        
    // Now construct an array of all arrays, as it is easier to
    // pass one argument than 8 individual arrays.

    arr := ([ah0,ah1,ah2,ah3],[av0,av1,av2,av3]) &

    // Now that we have the lists (arrays) of words, we can solve the problem

    all x in l 
        RtlGetCutPoint(cp) &
        FourWordSolve(x,a1,l3,arr) & ShowResult(h,x) &
        if ~FourWordQueryNext() then
            RtlSetCutPoint(cp)  // user does not want more solutions
        end
    end & FourWordDone() & 
    FourWordGUISolve(h)         // solve another set of letters

///////////////////////////////////////////////////////////////////////////////
//
// Collect all (non-zero) letters into one list.
//
///////////////////////////////////////////////////////////////////////////////
local proc CreateUsedLettersList(a:<[0..]->I,i:<I,lin :< list["A".."Z"], lout :> list ["A".."Z"]) iff
    if i < Len(a) then
        if a(i) <> 0 then 
            CreateUsedLettersList(a,i+1,(a(i),lin),lout) 
        else
            CreateUsedLettersList(a,i+1,lin,lout)
        end
    else
        lout = lin
    end 

///////////////////////////////////////////////////////////////////////////////
// Create applicable words for one row or column.
// Go through all words, weeding out those that are not applicable
//
// Input arguments:
//      a1: array of four letters for one row or column. May be partially 
//          initialized.
//      a2: array of allowable letters for uninitialized positions in a1.
//          (user provided "spare" letters)
//
// Output argument:
//      outword: word that is applicable based on information from a1,a2
//
///////////////////////////////////////////////////////////////////////////////
local pred GetWord(a1:<[0..3]->I,a2:<[0..]->I,outword:>S) iff
    x::[0..3]->["A".."Z"] & 
    i::I[0..] & i < Len(AllFourLetterWords) &   // this many words total
    x = AllFourLetterWords(i):[0..3]->["A".."Z"] &  
    if a1(0) <> 0 then x(0) = a1(0) else x(0) in a2 end &
    if a1(1) <> 0 then x(1) = a1(1) else x(1) in a2 end &
    if a1(2) <> 0 then x(2) = a1(2) else x(2) in a2 end &
    if a1(3) <> 0 then x(3) = a1(3) else x(3) in a2 end &
    y :> [0..3]->I & y = x & 
    outword = y:S

///////////////////////////////////////////////////////////////////////////////
//
//  Find one solution the the FourWord puzzle
//
///////////////////////////////////////////////////////////////////////////////
local pred FourWordSolve(s::[0..15]->["A".."Z"], a1:<[0..15]->I, l3:<list ["A".."Z"],arrs:<Arrs) iff
    ix::[0..]->>I & Len(ix,Len(l3)) &

    // Place known letters with known positions in the grid (at the known positions).
    Assign1(s,a1,0) &       

    // Assure all user provided letters are used somewhere in the grid
    Assign2(s,ix,l3,0,0) & 

    // Now place all available words into individual rows and columns.
    // The oder is not important, but may affect the execution time.
    // Generally, try to constrain the solution as much as you can as soon
    // as you can by interleaving the horizontal and vertical words.

    StoreHorizontalWord1(s,0,arrs.ah(0)) &     // row 0
    StoreVerticalWord1(s,0,arrs.av(0)) &       // column 0
    StoreHorizontalWord1(s,1,arrs.ah(1)) &     // row 1
    StoreVerticalWord1(s,1,arrs.av(1)) &       // columns 1
    StoreHorizontalWord1(s,2,arrs.ah(2)) &     // row 2    
    StoreVerticalWord1(s,2,arrs.av(2)) &       // column 2 
    StoreHorizontalWord1(s,3,arrs.ah(3)) &     // row 3    
    StoreVerticalWord1(s,3,arrs.av(3))         // column 3 

local pred StoreHorizontalWord1(grid::[0..15]->I,row:<I,aWords:<[0..]->S) iff
    wordix :: I & wordix < Len(aWords) & wordix >= 0 &    
    word = aWords(wordix) & 
    col = row*4 &
    grid(col+0) = word(0) &
    grid(col+1) = word(1) &
    grid(col+2) = word(2) &
    grid(col+3) = word(3) 

local pred StoreVerticalWord1(grid::[0..15]->I,col:<I,aWords:<[0..]->S) iff
    wordix :: I & wordix < Len(aWords) & wordix >= 0 & 
    word = aWords(wordix) & 
    grid(col)    = word(0) &
    grid(col+4)  = word(1) &
    grid(col+8)  = word(2) &
    grid(col+12) = word(3) 

///////////////////////////////////////////////////////////////////////////////
//
// Place the letters with know positions in the grid at those positions.
//
///////////////////////////////////////////////////////////////////////////////
local pred Assign1(grid::[0..15]->["A".."Z"],a1:<[0..15]->I,col:<I) iff
    if col < 16 then
        if a1(col) <> 0 then 
            grid(col) = a1(col) & Assign1(grid,a1,col+1)
        end
    end

///////////////////////////////////////////////////////////////////////////////
//
// Assign all letters somewhere in the grid:
//
//      grid(i) = letter
//
// where "i" is a grid index. 
// There may be several identical letters to be placed. This could lead 
// to multiple identical solutions, due to the number of permutations in 
// positions these identical letters can have. In order to avoid identical 
// solutions, we keep the list of letters in sorted order. Then if the
// "letter" is the same as the previuosly place letter, we simply demand that
//  
//      grid(i) = letter &
//      grid(j) = letter & j > i
//
///////////////////////////////////////////////////////////////////////////////
local pred Assign2(grid::[0..15]->["A".."Z"], ix::[0..]->>I,a3:<list ["A".."Z"],prev:<I,i:<I) iff
    if a3 = h,t then 
        grid(ix(i)) = h & 
        if h = prev then 
            if i > 0 then 
                ix(i) > ix(i-1) 
            end 
        end &
        Assign2(grid,ix,t,h,i+1)
    end

///////////////////////////////////////////////////////////////////////////////
//
//  Show the calculated result. Just let GUI do it.
//
///////////////////////////////////////////////////////////////////////////////
local proc ShowResult(h:<I,s:<[0..15]->["A".."Z"]) iff
    FourWordShowValues(h,s) 

///////////////////////////////////////////////////////////////////////////////
//
// External routines used by this program.
//
///////////////////////////////////////////////////////////////////////////////
// Initialize the external code
local subr FourWordCreateWindow(title:<S,w:>I) iff external 'FourWordExt':'FourWordCreateWindow'

// Query the external code for some initial FourWord values
// a1 = [0..15]->I : initialized values, 0 == uninintialized
// a2 = [0..]->I : letters to be placed 
local subr FourWordGetUserValues(w:<I,a1:>[0..15]->I,a2:>[0..]->I) iff external 'FourWordExt':'FourWordGetUserValues'

// Present the external code with one FourWord solution
local proc FourWordShowValues(w:<I,a:<[0..15]->["A".."Z"]) iff external 'FourWordExt':'FourWordShowValues'

// Notify the external code we are finished (there will be no more solutions)
local proc FourWordDone() iff external 'FourWordExt':'FourWordDone'

// Query the external code if another solution desired
local proc FourWordQueryNext() iff external 'FourWordExt':'FourWordQueryNext'

This page was created by F1toHTML