4-rings or 4-squares puzzle

From Rosetta Code
Task
4-rings or 4-squares puzzle
You are encouraged to solve this task according to the task description, using any language you may know.
Task

Replace       a, b, c, d, e, f,   and   g       with the decimal digits   LOW   ───►   HIGH
such that the sum of the letters inside of each of the four large squares add up to the same sum.

            ╔══════════════╗      ╔══════════════╗
            ║              ║      ║              ║
            ║      a       ║      ║      e       ║
            ║              ║      ║              ║
            ║          ┌───╫──────╫───┐      ┌───╫─────────┐
            ║          │   ║      ║   │      │   ║         │
            ║          │ b ║      ║ d │      │ f ║         │
            ║          │   ║      ║   │      │   ║         │
            ║          │   ║      ║   │      │   ║         │
            ╚══════════╪═══╝      ╚═══╪══════╪═══╝         │
                       │       c      │      │      g      │
                       │              │      │             │
                       │              │      │             │
                       └──────────────┘      └─────────────┘

Show all output here.


  •   Show all solutions for each letter being unique with
        LOW=1     HIGH=7
  •   Show all solutions for each letter being unique with
        LOW=3     HIGH=9
  •   Show only the   number   of solutions when each letter can be non-unique
        LOW=0     HIGH=9


Related task



ALGOL 68[edit]

As with the REXX solution, we use explicit loops to generate the permutations.

BEGIN
# solve the 4 rings or 4 squares puzzle #
# we need to find solutions to the equations: a + b = b + c + d = d + e + f = f + g #
# where a, b, c, d, e, f, g in lo : hi ( not necessarily unique ) #
# depending on show, the solutions will be printed or not #
PROC four rings = ( INT lo, hi, BOOL unique, show )VOID:
BEGIN
INT solutions := 0;
BOOL allow duplicates = NOT unique;
# calculate field width for printinhg solutions #
INT width := -1;
INT max := ABS IF ABS lo > ABS hi THEN lo ELSE hi FI;
WHILE max > 0 DO
width -:= 1;
max OVERAB 10
OD;
# find solutions #
FOR a FROM lo TO hi DO
FOR b FROM lo TO hi DO
IF allow duplicates OR a /= b THEN
INT t = a + b;
FOR c FROM lo TO hi DO
IF allow duplicates OR ( a /= c AND b /= c ) THEN
FOR d FROM lo TO hi DO
IF allow duplicates OR ( a /= d AND b /= d AND c /= d )
THEN
IF b + c + d = t THEN
FOR e FROM lo TO hi DO
IF allow duplicates
OR ( a /= e AND b /= e AND c /= e AND d /= e )
THEN
FOR f FROM lo TO hi DO
IF allow duplicates
OR ( a /= f AND b /= f AND c /= f AND d /= f AND e /= f )
THEN
IF d + e + f = t THEN
FOR g FROM lo TO hi DO
IF allow duplicates
OR ( a /= g AND b /= g AND c /= g AND d /= g AND e /= g AND f /= g )
THEN
IF f + g = t THEN
solutions +:= 1;
IF show THEN
print( ( whole( a, width ), whole( b, width )
, whole( c, width ), whole( d, width )
, whole( e, width ), whole( f, width )
, whole( g, width ), newline
)
)
FI
FI
FI
OD # g #
FI
FI
OD # f #
FI
OD # e #
FI
FI
OD # d #
FI
OD # c #
FI
OD # b #
OD # a # ;
print( ( whole( solutions, 0 )
, IF unique THEN " unique" ELSE " non-unique" FI
, " solutions in "
, whole( lo, 0 )
, " to "
, whole( hi, 0 )
, newline
, newline
)
)
END # four rings # ;
 
# find the solutions as required for the task #
four rings( 1, 7, TRUE, TRUE );
four rings( 3, 9, TRUE, TRUE );
four rings( 0, 9, FALSE, FALSE )
END
Output:
 3 7 2 1 5 4 6
 4 5 3 1 6 2 7
 4 7 1 3 2 6 5
 5 6 2 3 1 7 4
 6 4 1 5 2 3 7
 6 4 5 1 2 7 3
 7 2 6 1 3 5 4
 7 3 2 5 1 4 6
8 unique solutions in 1 to 7

 7 8 3 4 5 6 9
 8 7 3 5 4 6 9
 9 6 4 5 3 7 8
 9 6 5 4 3 8 7
4 unique solutions in 3 to 9

2860 non-unique solutions in 0 to 9

AppleScript[edit]

Translation of: JavaScript
Translation of: Haskell

(Structured search example)

use framework "Foundation" -- for basic NSArray sort
 
on run
unlines({"rings(true, enumFromTo(1, 7))\n", ¬
map(show, (rings(true, enumFromTo(1, 7)))), ¬
"\nrings(true, enumFromTo(3, 9))\n", ¬
map(show, (rings(true, enumFromTo(3, 9)))), ¬
"\nlength(rings(false, enumFromTo(0, 9)))\n", ¬
show(|length|(rings(false, enumFromTo(0, 9))))})
end run
 
-- RINGS -----------------------------------------------------------------------
 
-- rings :: noRepeatedDigits -> DigitList -> Lists of solutions
-- rings :: Bool -> [Int] -> [[Int]]
on rings(u, digits)
set ds to reverse_(sort(digits))
set h to head(ds)
 
-- QUEEN -------------------------------------------------------------------
script queen
on |λ|(q)
script
on |λ|(x)
x + q ≤ h
end |λ|
end script
set ts to filter(result, ds)
if u then
set bs to delete_(q, ts)
else
set bs to ds
end if
 
-- LEFT BISHOP and its ROOK-----------------------------------------
script leftBishop
on |λ|(lb)
set lRook to lb + q
if lRook > h then
{}
else
if u then
set rbs to difference(ts, {q, lb, lRook})
else
set rbs to ds
end if
 
-- RIGHT BISHOP and its ROOK ---------------------------
script rightBishop
on |λ|(rb)
set rRook to rb + q
if (rRook > h) or (u and (rRook = lb)) then
{}
else
set rookDelta to lRook - rRook
if u then
set ks to difference(ds, ¬
{q, lb, rb, rRook, lRook})
else
set ks to ds
end if
 
-- KNIGHTS LEFT AND RIGHT ------------------
script knights
on |λ|(k)
set k2 to k + rookDelta
 
if elem(k2, ks) and ((not u) or ¬
notElem(k2, ¬
{lRook, k, lb, q, rb, rRook})) then
{{lRook, k, lb, q, rb, k2, rRook}}
else
{}
end if
end |λ|
end script
 
concatMap(knights, ks)
end if
end |λ|
end script
 
concatMap(rightBishop, rbs)
end if
end |λ|
end script
 
concatMap(leftBishop, bs)
end |λ|
end script
 
concatMap(queen, ds)
end rings
 
-- GENERIC FUNCTIONS -----------------------------------------------------------
 
-- concatMap :: (a -> [b]) -> [a] -> [b]
on concatMap(f, xs)
set lst to {}
set lng to length of xs
tell mReturn(f)
repeat with i from 1 to lng
set lst to (lst & |λ|(contents of item i of xs, i, xs))
end repeat
end tell
return lst
end concatMap
 
-- delete :: Eq a => a -> [a] -> [a]
on delete_(x, xs)
set mbIndex to elemIndex(x, xs)
set lng to length of xs
 
if mbIndex is not missing value then
if lng > 1 then
if mbIndex = 1 then
items 2 thru -1 of xs
else if mbIndex = lng then
items 1 thru -2 of xs
else
tell xs to items 1 thru (mbIndex - 1) & ¬
items (mbIndex + 1) thru -1
end if
else
{}
end if
else
xs
end if
end delete_
 
-- difference :: [a] -> [a] -> [a]
on difference(xs, ys)
script mf
on except(a, y)
if a contains y then
my delete_(y, a)
else
a
end if
end except
end script
 
foldl(except of mf, xs, ys)
end difference
 
-- elem :: Eq a => a -> [a] -> Bool
on elem(x, xs)
xs contains x
end elem
 
-- elemIndex :: a -> [a] -> Maybe Int
on elemIndex(x, xs)
set lng to length of xs
repeat with i from 1 to lng
if x = (item i of xs) then return i
end repeat
return missing value
end elemIndex
 
-- enumFromTo :: Int -> Int -> [Int]
on enumFromTo(m, n)
if n < m then
set d to -1
else
set d to 1
end if
set lst to {}
repeat with i from m to n by d
set end of lst to i
end repeat
return lst
end enumFromTo
 
-- filter :: (a -> Bool) -> [a] -> [a]
on filter(f, xs)
tell mReturn(f)
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
return lst
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
 
-- head :: [a] -> a
on head(xs)
if length of xs > 0 then
item 1 of xs
else
missing value
end if
end head
 
-- intercalate :: Text -> [Text] -> Text
on intercalate(strText, lstText)
set {dlm, my text item delimiters} to {my text item delimiters, strText}
set strJoined to lstText as text
set my text item delimiters to dlm
return strJoined
end intercalate
 
-- length :: [a] -> Int
on |length|(xs)
length of xs
end |length|
 
-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
tell mReturn(f)
set lng to length of xs
set lst to {}
repeat with i from 1 to lng
set end of lst to |λ|(item i of xs, i, xs)
end repeat
return lst
end tell
end map
 
-- Lift 2nd class handler function into 1st class script wrapper
-- mReturn :: Handler -> Script
on mReturn(f)
if class of f is script then
f
else
script
property |λ| : f
end script
end if
end mReturn
 
-- notElem :: Eq a => a -> [a] -> Bool
on notElem(x, xs)
xs does not contain x
end notElem
 
-- reverse_ :: [a] -> [a]
on |reverse|:xs
if class of xs is text then
(reverse of characters of xs) as text
else
reverse of xs
end if
end |reverse|:
 
-- show :: a -> String
on show(e)
set c to class of e
if c = list then
script serialized
on |λ|(v)
show(v)
end |λ|
end script
 
"[" & intercalate(", ", map(serialized, e)) & "]"
else if c = record then
script showField
on |λ|(kv)
set {k, ev} to kv
"\"" & k & "\":" & show(ev)
end |λ|
end script
 
"{" & intercalate(", ", ¬
map(showField, zip(allKeys(e), allValues(e)))) & "}"
else if c = date then
"\"" & iso8601Z(e) & "\""
else if c = text then
"\"" & e & "\""
else if (c = integer or c = real) then
e as text
else if c = class then
"null"
else
try
e as text
on error
("«" & c as text) & "»"
end try
end if
end show
 
-- sort :: [a] -> [a]
on sort(xs)
((current application's NSArray's arrayWithArray:xs)'s ¬
sortedArrayUsingSelector:"compare:") as list
end sort
 
-- unlines :: [String] -> String
on unlines(xs)
intercalate(linefeed, xs)
end unlines
Output:
rings(true, enumFromTo(1, 7))

[7, 3, 2, 5, 1, 4, 6]
[6, 4, 1, 5, 2, 3, 7]
[5, 6, 2, 3, 1, 7, 4]
[4, 7, 1, 3, 2, 6, 5]
[7, 2, 6, 1, 3, 5, 4]
[6, 4, 5, 1, 2, 7, 3]
[4, 5, 3, 1, 6, 2, 7]
[3, 7, 2, 1, 5, 4, 6]

rings(true, enumFromTo(3, 9))

[9, 6, 4, 5, 3, 7, 8]
[8, 7, 3, 5, 4, 6, 9]
[9, 6, 5, 4, 3, 8, 7]
[7, 8, 3, 4, 5, 6, 9]

length(rings(false, enumFromTo(0, 9)))

2860

C[edit]

 
#include <stdio.h>
 
#define TRUE 1
#define FALSE 0
 
int a,b,c,d,e,f,g;
int lo,hi,unique,show;
int solutions;
 
void
bf()
{
for (f = lo;f <= hi; f++)
if ((!unique) ||
((f != a) && (f != c) && (f != d) && (f != g) && (f != e)))
{
b = e + f - c;
if ((b >= lo) && (b <= hi) &&
((!unique) || ((b != a) && (b != c) &&
(b != d) && (b != g) && (b != e) && (b != f))))
{
solutions++;
if (show)
printf("%d %d %d %d %d %d %d\n",a,b,c,d,e,f,g);
}
}
}
 
 
void
ge()
{
for (e = lo;e <= hi; e++)
if ((!unique) || ((e != a) && (e != c) && (e != d)))
{
g = d + e;
if ((g >= lo) && (g <= hi) &&
((!unique) || ((g != a) && (g != c) &&
(g != d) && (g != e))))
bf();
}
}
 
void
acd()
{
for (c = lo;c <= hi; c++)
for (d = lo;d <= hi; d++)
if ((!unique) || (c != d))
{
a = c + d;
if ((a >= lo) && (a <= hi) &&
((!unique) || ((c != 0) && (d != 0))))
ge();
}
}
 
 
void
foursquares(int plo,int phi, int punique,int pshow)
{
lo = plo;
hi = phi;
unique = punique;
show = pshow;
solutions = 0;
 
printf("\n");
 
acd();
 
if (unique)
printf("\n%d unique solutions in %d to %d\n",solutions,lo,hi);
else
printf("\n%d non-unique solutions in %d to %d\n",solutions,lo,hi);
}
 
main()
{
foursquares(1,7,TRUE,TRUE);
foursquares(3,9,TRUE,TRUE);
foursquares(0,9,FALSE,FALSE);
}
 

Output


4 7 1 3 2 6 5
6 4 1 5 2 3 7
3 7 2 1 5 4 6
5 6 2 3 1 7 4
7 3 2 5 1 4 6
4 5 3 1 6 2 7
6 4 5 1 2 7 3
7 2 6 1 3 5 4

8 unique solutions in 1 to 7

7 8 3 4 5 6 9
8 7 3 5 4 6 9
9 6 4 5 3 7 8
9 6 5 4 3 8 7

4 unique solutions in 3 to 9


2860 non-unique solutions in 0 to 9

Common Lisp[edit]

 
(defpackage four-rings
(:use common-lisp)
(:export display-solutions))
(in-package four-rings)
 
(defun correct-answer-p (a b c d e f g)
(let ((v (+ a b)))
(and (equal v (+ b c d))
(equal v (+ d e f))
(equal v (+ f g)))))
 
(defun combinations-if (func len unique min max)
(let ((results nil))
(labels ((inner (cur)
(if (eql (length cur) len)
(when (apply func (reverse cur))
(push cur results))
(dotimes (i (- max min))
(when (or (not unique)
(not (member (+ i min) cur)))
(inner (append (list (+ i min)) cur)))))))
(inner nil))
results))
 
(defun four-rings-solutions (low high unique)
(combinations-if #'correct-answer-p 7 unique low (1+ high)))
 
(defun display-solutions ()
(let ((letters '((a b c d e f g))))
(format t "Low 1, High 7, unique letters: ~%~{~{~3A~}~%~}~%"
(append letters (four-rings-solutions 1 7 t)))
(format t "Low 3, High 9, unique letters: ~%~{~{~3A~}~%~}~%"
(append letters (four-rings-solutions 3 9 t)))
(format t "Number of solutions for Low 0, High 9 non-unique:~%~A~%"
(length (four-rings-solutions 0 9 nil)))))
 

Output:

CL-USER> (four-rings:display-solutions)
Low 1, High 7, unique letters: 
A  B  C  D  E  F  G  
6  4  1  5  2  3  7  
4  5  3  1  6  2  7  
3  7  2  1  5  4  6  
7  3  2  5  1  4  6  
4  7  1  3  2  6  5  
5  6  2  3  1  7  4  
7  2  6  1  3  5  4  
6  4  5  1  2  7  3  

Low 3, High 9, unique letters: 
A  B  C  D  E  F  G  
7  8  3  4  5  6  9  
8  7  3  5  4  6  9  
9  6  4  5  3  7  8  
9  6  5  4  3  8  7  

Number of solutions for Low 0, High 9 non-unique:
2860
NIL

F#[edit]

 
(* A simple function to generate the sequence
Nigel Galloway: January 31st., 2017 *)

type G = {d:int;x:int;b:int;f:int}
let N n g =
{(max (n-g) n) .. (min (g-n) g)} |> Seq.collect(fun d->{(max (d+n+n) (n+n))..(min (g+g) (d+g+g))} |> Seq.collect(fun x ->
seq{for a in n .. g do for b in n .. g do if (a+b) = x then for c in n .. g do if (b+c+d) = x then yield b} |> Seq.collect(fun b ->
seq{for f in n .. g do for G in n .. g do if (f+G) = x then for e in n .. g do if (f+e+d) = x then yield f} |> Seq.map(fun f -> {d=d;x=x;b=b;f=f}))))
 

Then:

 
printfn "%d" (Seq.length (N 0 9))
 
Output:
2860
 
(* A simple function to generate the sequence with unique values
Nigel Galloway: January 31st., 2017 *)

type G = {d:int;x:int;b:int;f:int}
let N n g =
{(max (n-g) n) .. (min (g-n) g)} |> Seq.filter(fun d -> d <> 0) |> Seq.collect(fun d->{(max (d+n+n) (n+n)) .. (min (g+g) (d+g+g))} |> Seq.collect(fun x ->
seq{for a in n .. g do if a <> d then for b in n .. g do if (a+b) = x && b <> a && b <> d then for c in n .. g do if (b+c+d) = x && c <> d && c <> a && c <> b then yield b} |> Seq.collect(fun b ->
seq{for f in n .. g do if f <> d && f <> b && f <> (x-b) && f <> (x-d-b) then for G in n .. g do if (f+G) = x && G <> d && G <> b && G <> f && G <> (x-b) && G <> (x-d-b) then for e in n .. g do if (f+e+d) = x && e <> d && e <> b && e <> f && e <> G && e <> (x-b) && e <> (x-d-b) then yield f} |> Seq.map(fun f -> {d=d;x=x;b=b;f=f}))))
 

Then:

 
for n in N 1 7 do printfn "%d,%d,%d,%d,%d,%d,%d" (n.x-n.b) n.b (n.x-n.d-n.b) n.d (n.x-n.d-n.f) n.f (n.x-n.f)
 
Output:
4,5,3,1,6,2,7
7,2,6,1,3,5,4
3,7,2,1,5,4,6
6,4,5,1,2,7,3
4,7,1,3,2,6,5
5,6,2,3,1,7,4
6,4,1,5,2,3,7
7,3,2,5,1,4,6

and:

 
for n in N 3 9 do printfn "%d,%d,%d,%d,%d,%d,%d" (n.x-n.b) n.b (n.x-n.d-n.b) n.d (n.x-n.d-n.f) n.f (n.x-n.f)
 
Output:
7,8,3,4,5,6,9
9,6,5,4,3,8,7
8,7,3,5,4,6,9
9,6,4,5,3,7,8

FreeBASIC[edit]

' version 18-03-2017
' compile with: fbc -s console
 
' TRUE/FALSE are built-in constants since FreeBASIC 1.04
' But we have to define them for older versions.
#Ifndef TRUE
#Define FALSE 0
#Define TRUE Not FALSE
#EndIf
 
Sub four_rings(low As Long, high As Long, unique As Long, show As Long)
 
Dim As Long a, b, c, d, e, f, g
Dim As ULong t, total
Dim As ULong l = Len(Str(high))
If l < Len(Str(low)) Then l = Len(Str(low))
 
 
If show = TRUE Then
For a = 97 To 103
Print Space(l); Chr(a);
Next
Print
Print String((l +1) * 7, "=");
Print
End If
 
For a = low To high
For b = low To high
If unique = TRUE Then
If b = a Then Continue For
End If
t = a + b
For c = low To high
If unique = TRUE Then
If c = a OrElse c = b Then Continue For
End If
For d = low To high
If unique = TRUE Then
If d = a OrElse d = b OrElse d = c Then Continue For
End If
If b + c + d = t Then
For e = low To high
If unique = TRUE Then
If e = a OrElse e = b OrElse e = c OrElse e = d Then Continue For
End If
For f = low To high
If unique = TRUE Then
If f = a OrElse f = b OrElse f = c OrElse f = d OrElse f = e Then Continue For
End If
If d + e + f = t Then
For g = low To high
If unique = TRUE Then
If g = a OrElse g = b OrElse g = c OrElse g = d OrElse g = e OrElse g = f Then Continue For
End If
If f + g = t Then
total += 1
If show = TRUE Then
Print Using String(l +1, "#"); a; b; c; d; e; f; g
End If
End If
Next
End If
Next
Next
End If
Next
Next
Next
Next
 
If unique = TRUE Then
Print
Print total; " Unique solutions for "; Str(low); " to "; Str(high)
Else
Print total; " Non unique solutions for "; Str(low); " to "; Str(high)
End If
Print String(40, "-") : Print
End Sub
 
' ------=< MAIN >=------
 
four_rings(1, 7, TRUE, TRUE)
four_rings(3, 9, TRUE, TRUE)
four_rings(0, 9, FALSE, FALSE)
 
' empty keyboard buffer
While InKey <> "" : Wend
Print : Print "hit any key to end program"
Sleep
End
Output:
 a b c d e f g
==============
 3 7 2 1 5 4 6
 4 5 3 1 6 2 7
 4 7 1 3 2 6 5
 5 6 2 3 1 7 4
 6 4 1 5 2 3 7
 6 4 5 1 2 7 3
 7 2 6 1 3 5 4
 7 3 2 5 1 4 6

8 Unique solutions for 1 to 7
----------------------------------------

 a b c d e f g
==============
 7 8 3 4 5 6 9
 8 7 3 5 4 6 9
 9 6 4 5 3 7 8
 9 6 5 4 3 8 7

4 Unique solutions for 3 to 9
----------------------------------------

2860 Non unique solutions for 0 to 9
----------------------------------------

Go[edit]

package main
 
import "fmt"
 
func main(){
n, c := getCombs(1,7,true)
fmt.Printf("%d unique solutions in 1 to 7\n",n)
fmt.Println(c)
n, c = getCombs(3,9,true)
fmt.Printf("%d unique solutions in 3 to 9\n",n)
fmt.Println(c)
n, _ = getCombs(0,9,false)
fmt.Printf("%d non-unique solutions in 0 to 9\n",n)
}
 
func getCombs(low,high int,unique bool) (num int,validCombs [][]int){
for a := low; a <= high; a++ {
for b := low; b <= high; b++ {
for c := low; c <= high; c++ {
for d := low; d <= high; d++ {
for e := low; e <= high; e++ {
for f := low; f <= high; f++ {
for g := low; g <= high; g++ {
if validComb(a,b,c,d,e,f,g) {
if unique{
if isUnique(a,b,c,d,e,f,g) {
num++
validCombs = append(validCombs,[]int{a,b,c,d,e,f,g})
}
}else{
num++
validCombs = append(validCombs,[]int{a,b,c,d,e,f,g})
}
}
}
}
}
}
}
}
}
return
}
func isUnique(a,b,c,d,e,f,g int) (res bool) {
data := make(map[int]int)
data[a]++
data[b]++
data[c]++
data[d]++
data[e]++
data[f]++
data[g]++
if len(data) == 7 {
return true
}else {
return false
}
}
func validComb(a,b,c,d,e,f,g int) bool{
square1 := a + b
square2 := b + c + d
square3 := d + e + f
square4 := f + g
return square1 == square2 && square2 == square3 && square3 == square4
}
 
Output:
8 unique solutions in 1 to 7
[[3 7 2 1 5 4 6] [4 5 3 1 6 2 7] [4 7 1 3 2 6 5] [5 6 2 3 1 7 4] [6 4 1 5 2 3 7] [6 4 5 1 2 7 3] [7 2 6 1 3 5 4] [7 3 2 5 1 4 6]]
4 unique solutions in 3 to 9
[[7 8 3 4 5 6 9] [8 7 3 5 4 6 9] [9 6 4 5 3 7 8] [9 6 5 4 3 8 7]]
2860 non-unique solutions in 0 to 9

Haskell[edit]

By exhaustive search[edit]

import Data.List
import Control.Monad
 
perms :: (Eq a) => [a] -> [[a]]
perms [] = [[]]
perms xs = [ x:xr | x <- xs, xr <- perms (xs\\[x]) ]
 
combs :: (Eq a) => Int -> [a] -> [[a]]
combs 0 _ = [[]]
combs n xs = [ x:xr | x <- xs, xr <- combs (n-1) xs ]
 
ringCheck :: [Int] -> Bool
ringCheck [x0, x1, x2, x3, x4, x5, x6] =
v == x1+x2+x3
&& v == x3+x4+x5
&& v == x5+x6
where v = x0 + x1
 
fourRings :: Int -> Int -> Bool -> Bool -> IO ()
fourRings low high allowRepeats verbose = do
let candidates = if allowRepeats
then combs 7 [low..high]
else perms [low..high]
 
solutions = filter ringCheck candidates
 
when verbose $ mapM_ print solutions
 
putStrLn $ show (length solutions)
++ (if allowRepeats then " non" else "")
++ " unique solutions for "
++ show low
++ " to "
++ show high
 
putStrLn ""
 
main = do
fourRings 1 7 False True
fourRings 3 9 False True
fourRings 0 9 True False
Output:
[3,7,2,1,5,4,6]
[4,5,3,1,6,2,7]
[4,7,1,3,2,6,5]
[5,6,2,3,1,7,4]
[6,4,1,5,2,3,7]
[6,4,5,1,2,7,3]
[7,2,6,1,3,5,4]
[7,3,2,5,1,4,6]
8 unique solutions for 1 to 7

[7,8,3,4,5,6,9]
[8,7,3,5,4,6,9]
[9,6,4,5,3,7,8]
[9,6,5,4,3,8,7]
4 unique solutions for 3 to 9

2860 non unique solutions for 0 to 9

By structured search[edit]

For a faster solution (under a third of a second, vs over 25 seconds on this system for the brute force approach above), we can nest a series of smaller and more focused searches from the central digit outwards.

Two things to notice:

  1. If we call the central digit the Queen, then in any solution the Queen plus its left neighbour (left Bishop) must sum to the value of the left Rook (leftmost digit). Symmetrically, the right Rook must be the sum of the Queen and right Bishop.
  2. The difference between the left Rook and the right Rook must be (minus) the difference between the left Knight (between bishop and rook) and the right Knight.


Nesting four bind operators (>>=), we can then build the set of solutions in the order: Queens, Left Bishops, Left Rooks, Right Bishops, Right Rooks, Knights. Probably less readable, but already fast, and could be further optimised.

import Data.List (delete, sortBy, (\\))
 
rings :: Bool -> [Int] -> [(Int, Int, Int, Int, Int, Int, Int)]
rings u digits =
let ds = sortBy (flip compare) digits
h = head ds
in ds >>=
-- QUEEN ------------------------------------------------------------------
(\q ->
let ts = filter ((<= h) . (q +)) ds
bs =
if u
then delete q ts
else ds
in bs >>=
-- LEFT BISHOP AND ROOK --------------------------------------------
(\lb ->
let lRook = lb + q
in if lRook <= h
then let rbs =
if u
then ts \\ [q, lb, lRook]
else ds
in rbs >>=
-- RIGHT BISHOP AND ROOK --------------------------
(\rb ->
let rRook = q + rb
in if (rRook <= h) && (not u || (rRook /= lb))
then let ks =
if u
then ds \\
[ q
, lb
, rb
, rRook
, lRook
]
else ds
rookDelta = lRook - rRook
in ks >>=
-- SOLUTION WITH KNIGHTS ---------
(\k ->
let k2 = k + rookDelta
in [ ( lRook
, k
, lb
, q
, rb
, k2
, rRook)
| (k2 `elem` ks) &&
(not u ||
notElem
k2
[ lRook
, k
, lb
, q
, rb
, rRook
]) ])
else [])
else []))
 
-- TEST ------------------------------------------------------------------------
main :: IO ()
main = do
putStrLn "rings True [1 .. 7]\n"
mapM_ print $ rings True [1 .. 7]
putStrLn "\nrings True [3 .. 9]\n"
mapM_ print $ rings True [3 .. 9]
putStrLn "\nlength (rings False [0 .. 9])\n"
print $ length (rings False [0 .. 9])
Output:
rings True [1 .. 7]

(7,3,2,5,1,4,6)
(6,4,1,5,2,3,7)
(5,6,2,3,1,7,4)
(4,7,1,3,2,6,5)
(7,2,6,1,3,5,4)
(6,4,5,1,2,7,3)
(4,5,3,1,6,2,7)
(3,7,2,1,5,4,6)

rings True [3 .. 9]

(9,6,4,5,3,7,8)
(8,7,3,5,4,6,9)
(9,6,5,4,3,8,7)
(7,8,3,4,5,6,9)

length (rings False [0 .. 9])

2860

JavaScript[edit]

ES6[edit]

Translation of: Haskell
(Structured search version)
(() => {
 
// RINGS -------------------------------------------------------------------
 
// rings :: noRepeatedDigits -> DigitList -> Lists of solutions
// rings :: Bool -> [Int] -> [[Int]]
const rings = (u, digits) => {
const
ds = sortBy(flip(compare), digits),
h = head(ds);
 
// QUEEN (i.e. middle digit of 7)---------------------------------------
return concatMap(
q => {
const
ts = filter(x => (x + q) <= h, ds),
bs = u ? delete_(q, ts) : ds;
 
// LEFT BISHOP (next to queen) AND ITS ROOK (leftmost digit)----
return concatMap(
lb => {
const lRook = lb + q;
return lRook > h ? [] : (() => {
const rbs = u ? difference(ts, [q, lb, lRook]) : ds;
 
// RIGHT BISHOP AND ITS ROOK -----------------------
return concatMap(rb => {
const rRook = q + rb;
return ((rRook > h) || (u && (rRook === lb))) ? (
[]
) : (() => {
const
rookDelta = lRook - rRook,
ks = u ? difference(
ds, [q, lb, rb, rRook, lRook]
) : ds;
 
// KNIGHTS LEFT AND RIGHT ------------------
return concatMap(k => {
const k2 = k + rookDelta;
return (elem(k2, ks) &&
(!u || notElem(k2, [
lRook, k, lb, q, rb, rRook
]))) ? (
[
[lRook, k, lb, q, rb, k2, rRook]
]
) : [];
}, ks);
})();
}, rbs);
})();
},
bs
);
},
ds
);
};
 
// GENERIC FUNCTIONS ------------------------------------------------------
 
// compare :: a -> a -> Ordering
const compare = (a, b) => a < b ? -1 : (a > b ? 1 : 0);
 
// concatMap :: (a -> [b]) -> [a] -> [b]
const concatMap = (f, xs) => [].concat.apply([], xs.map(f));
 
// delete_ :: Eq a => a -> [a] -> [a]
const delete_ = (x, xs) =>
xs.length > 0 ? (
(x === xs[0]) ? (
xs.slice(1)
) : [xs[0]].concat(delete_(x, xs.slice(1)))
) : [];
 
// (\\)  :: (Eq a) => [a] -> [a] -> [a]
const difference = (xs, ys) =>
ys.reduce((a, x) => delete_(x, a), xs);
 
// elem :: Eq a => a -> [a] -> Bool
const elem = (x, xs) => xs.indexOf(x) !== -1;
 
// enumFromTo :: Int -> Int -> [Int]
const enumFromTo = (m, n) =>
Array.from({
length: Math.floor(n - m) + 1
}, (_, i) => m + i);
 
// filter :: (a -> Bool) -> [a] -> [a]
const filter = (f, xs) => xs.filter(f);
 
// flip :: (a -> b -> c) -> b -> a -> c
const flip = f => (a, b) => f.apply(null, [b, a]);
 
// head :: [a] -> a
const head = xs => xs.length ? xs[0] : undefined;
 
// length :: [a] -> Int
const length = xs => xs.length;
 
// map :: (a -> b) -> [a] -> [b]
const map = (f, xs) => xs.map(f);
 
// notElem :: Eq a => a -> [a] -> Bool
const notElem = (x, xs) => xs.indexOf(x) === -1;
 
// show :: a -> String
const show = x => JSON.stringify(x); //, null, 2);
 
// sortBy :: (a -> a -> Ordering) -> [a] -> [a]
const sortBy = (f, xs) => xs.sort(f);
 
// unlines :: [String] -> String
const unlines = xs => xs.join('\n');
 
 
// TEST --------------------------------------------------------------------
return unlines([
'rings(true, enumFromTo(1,7))\n',
unlines(map(show, rings(true, enumFromTo(1, 7)))),
'\nrings(true, enumFromTo(3, 9))\n',
unlines(map(show, rings(true, enumFromTo(3, 9)))),
'\nlength(rings(false, enumFromTo(0, 9)))\n',
length(rings(false, enumFromTo(0, 9)))
.toString(),
''
]);
})();
Output:
rings(true, enumFromTo(1,7))

[7,3,2,5,1,4,6]
[6,4,1,5,2,3,7]
[5,6,2,3,1,7,4]
[4,7,1,3,2,6,5]
[7,2,6,1,3,5,4]
[6,4,5,1,2,7,3]
[4,5,3,1,6,2,7]
[3,7,2,1,5,4,6]

rings(true, enumFromTo(3, 9))

[9,6,4,5,3,7,8]
[8,7,3,5,4,6,9]
[9,6,5,4,3,8,7]
[7,8,3,4,5,6,9]

length(rings(false, enumFromTo(0, 9)))

2860

Kotlin[edit]

Translation of: C
// version 1.1.2
 
class FourSquares(
private val lo: Int,
private val hi: Int,
private val unique: Boolean,
private val show: Boolean
) {
private var a = 0
private var b = 0
private var c = 0
private var d = 0
private var e = 0
private var f = 0
private var g = 0
private var s = 0
 
init {
println()
if (show) {
println("a b c d e f g")
println("-------------")
}
acd()
println("\n$s ${if (unique) "unique" else "non-unique"} solutions in $lo to $hi")
}
 
private fun acd() {
c = lo
while (c <= hi) {
d = lo
while (d <= hi) {
if (!unique || c != d) {
a = c + d
if ((a in lo..hi) && (!unique || (c != 0 && d!= 0))) ge()
}
d++
}
c++
}
}
 
private fun bf() {
f = lo
while (f <= hi) {
if (!unique || (f != a && f != c && f != d && f != e && f!= g)) {
b = e + f - c
if ((b in lo..hi) && (!unique || (b != a && b != c && b != d && b != e && b != f && b!= g))) {
s++
if (show) println("$a $b $c $d $e $f $g")
}
}
f++
}
}
 
private fun ge() {
e = lo
while (e <= hi) {
if (!unique || (e != a && e != c && e != d)) {
g = d + e
if ((g in lo..hi) && (!unique || (g != a && g != c && g != d && g != e))) bf()
}
e++
}
}
}
 
fun main(args: Array<String>) {
FourSquares(1, 7, true, true)
FourSquares(3, 9, true, true)
FourSquares(0, 9, false, false)
}
Output:
a b c d e f g
-------------
4 7 1 3 2 6 5
6 4 1 5 2 3 7
3 7 2 1 5 4 6
5 6 2 3 1 7 4
7 3 2 5 1 4 6
4 5 3 1 6 2 7
6 4 5 1 2 7 3
7 2 6 1 3 5 4

8 unique solutions in 1 to 7

a b c d e f g
-------------
7 8 3 4 5 6 9
8 7 3 5 4 6 9
9 6 4 5 3 7 8
9 6 5 4 3 8 7

4 unique solutions in 3 to 9


2860 non-unique solutions in 0 to 9

Pascal[edit]

Works with: Free Pascal

There are so few solutions of 7 consecutive numbers, so I used a modified version, to get all the expected solutions at once.

program square4;
{$MODE DELPHI}
{$R+,O+}
const
LoDgt = 0;
HiDgt = 9;
type
tchkset = set of LoDgt..HiDgt;
tSol = record
solMin : integer;
solDat : array[1..7] of integer;
end;
 
var
sum,a,b,c,d,e,f,g,cnt,uniqueCount : NativeInt;
sol : array of tSol;
 
procedure SolOut;
var
i,j,mn: NativeInt;
Begin
mn := 0;
repeat
writeln(mn:3,' ...',mn+6:3);
For i := Low(sol) to High(sol) do
with sol[i] do
IF solMin = mn then
Begin
For j := 1 to 7 do
write(solDat[j]:3);
writeln;
end;
writeln;
inc(mn);
until mn > HiDgt-6;
end;
 
function CheckUnique:Boolean;
var
i,sum,mn: NativeInt;
chkset : tchkset;
 
Begin
chkset:= [];
include(chkset,a);include(chkset,b);include(chkset,c);
include(chkset,d);include(chkset,e);include(chkset,f);
include(chkset,g);
sum := 0;
For i := LoDgt to HiDgt do
IF i in chkset then
inc(sum);
 
result := sum = 7;
IF result then
begin
inc(uniqueCount);
//find the lowest entry
mn:= LoDgt;
For i := LoDgt to HiDgt do
IF i in chkset then
Begin
mn := i;
BREAK;
end;
// are they consecutive
For i := mn+1 to mn+6 do
IF NOT(i in chkset) then
EXIT;
 
setlength(sol,Length(sol)+1);
with sol[high(sol)] do
Begin
solMin:= mn;
solDat[1]:= a;solDat[2]:= b;solDat[3]:= c;
solDat[4]:= d;solDat[5]:= e;solDat[6]:= f;
solDat[7]:= g;
end;
end;
end;
 
Begin
cnt := 0;
uniqueCount := 0;
For a:= LoDgt to HiDgt do
Begin
For b := LoDgt to HiDgt do
Begin
sum := a+b;
//a+b = b+c+d => a = c+d => d := a-c
For c := a-LoDgt downto LoDgt do
begin
d := a-c;
e := sum-d;
IF e>HiDgt then
e:= HiDgt;
For e := e downto LoDgt do
begin
f := sum-e-d;
IF f in [loDGt..Hidgt]then
Begin
g := sum-f;
IF g in [loDGt..Hidgt]then
Begin
inc(cnt);
CheckUnique;
end;
end;
end;
end;
end;
end;
SolOut;
writeln(' solution count for ',loDgt,' to ',HiDgt,' = ',cnt);
writeln('unique solution count for ',loDgt,' to ',HiDgt,' = ',uniqueCount);
end.
Output:
  0 ...  6
  4  2  3  1  5  0  6
  5  1  3  2  4  0  6
  6  0  5  1  3  2  4
  6  0  4  2  3  1  5

  1 ...  7
  3  7  2  1  5  4  6
  4  5  3  1  6  2  7
  4  7  1  3  2  6  5
  5  6  2  3  1  7  4
  6  4  5  1  2  7  3
  6  4  1  5  2  3  7
  7  2  6  1  3  5  4
  7  3  2  5  1  4  6

  2 ...  8
  5  7  3  2  6  4  8
  5  8  3  2  4  7  6
  5  8  2  3  4  6  7
  6  7  4  2  3  8  5
  7  4  5  2  6  3  8
  7  6  4  3  2  8  5
  8  3  6  2  5  4  7
  8  4  6  2  3  7  5

  3 ...  9
  7  8  3  4  5  6  9
  8  7  3  5  4  6  9
  9  6  5  4  3  8  7
  9  6  4  5  3  7  8

       solution count for 0 to 9 = 2860
unique solution count for 0 to 9 = 192

Perl 6[edit]

Works with: Rakudo version 2016.12
sub four-squares ( @list, :$unique=1, :$show=1 ) {
 
my @solutions;
 
for $unique.&combos -> @c {
@solutions.push: @c if [==]
@c[0] + @c[1],
@c[1] + @c[2] + @c[3],
@c[3] + @c[4] + @c[5],
@c[5] + @c[6];
}
 
say +@solutions, ($unique ?? ' ' !! ' non-'), "unique solutions found using {join(', ', @list)}.\n";
 
my $f = "[email protected]}s";
 
say join "\n", (('a'..'g').fmt: $f), @solutions».fmt($f), "\n" if $show;
 
multi combos ( $ where so * ) { @list.combinations(7).map: |*.permutations }
 
multi combos ( $ where not * ) { [X] @list xx 7 }
}
 
# TASK
four-squares( [1..7] );
four-squares( [3..9] );
four-squares( [8, 9, 11, 12, 17, 18, 20, 21] );
four-squares( [0..9], :unique(0), :show(0) );
Output:
8 unique solutions found using 1, 2, 3, 4, 5, 6, 7.

a b c d e f g
3 7 2 1 5 4 6
4 5 3 1 6 2 7
4 7 1 3 2 6 5
5 6 2 3 1 7 4
6 4 1 5 2 3 7
6 4 5 1 2 7 3
7 2 6 1 3 5 4
7 3 2 5 1 4 6


4 unique solutions found using 3, 4, 5, 6, 7, 8, 9.

a b c d e f g
7 8 3 4 5 6 9
8 7 3 5 4 6 9
9 6 4 5 3 7 8
9 6 5 4 3 8 7


8 unique solutions found using 8, 9, 11, 12, 17, 18, 20, 21.

 a  b  c  d  e  f  g
17 21  8  9 11 18 20
20 18 11  9  8 21 17
17 21  9  8 12 18 20
20 18  8 12  9 17 21
20 18 12  8  9 21 17
21 17  9 12  8 18 20
20 18 11  9 12 17 21
21 17 12  9 11 18 20


2860 non-unique solutions found using 0, 1, 2, 3, 4, 5, 6, 7, 8, 9.

Phix[edit]

integer solutions
 
procedure check(sequence set, bool show)
integer {a,b,c,d,e,f,g} = set, ab = a+b
if ab=b+d+c and ab=d+e+f and ab=f+g then
solutions += 1
if show then
 ?set
end if
end if
end procedure
 
procedure foursquares(integer lo, integer hi, bool uniq, bool show)
sequence set = repeat(lo,7)
solutions = 0
if uniq then
for i=1 to 7 do
set[i] = lo+i-1
end for
for i=1 to factorial(7) do
check(permute(i,set),show)
end for
else
integer done = 0
while not done do
check(set,show)
for i=1 to 7 do
set[i] += 1
if set[i]<=hi then exit end if
if i=7 then
done = 1
exit
end if
set[i] = lo
end for
end while
end if
printf(1,"%d solutions\n",solutions)
end procedure
foursquares(1,7,uniq:=True,show:=True)
foursquares(3,9,True,True)
foursquares(0,9,False,False)
Output:
{6,4,5,1,2,7,3}
{3,7,2,1,5,4,6}
{6,4,1,5,2,3,7}
{4,7,1,3,2,6,5}
{7,3,2,5,1,4,6}
{5,6,2,3,1,7,4}
{4,5,3,1,6,2,7}
{7,2,6,1,3,5,4}
8 solutions
{7,8,3,4,5,6,9}
{8,7,3,5,4,6,9}
{9,6,4,5,3,7,8}
{9,6,5,4,3,8,7}
4 solutions
2860 solutions

PL/SQL[edit]

Works with: Oracle
 
CREATE TABLE allints (v NUMBER);
CREATE TABLE results
(
a NUMBER,
b NUMBER,
c NUMBER,
d NUMBER,
e NUMBER,
f NUMBER,
g NUMBER
);
 
CREATE OR REPLACE PROCEDURE foursquares(lo NUMBER,hi NUMBER,uniq BOOLEAN,show BOOLEAN)
AS
a NUMBER;
b NUMBER;
c NUMBER;
d NUMBER;
e NUMBER;
f NUMBER;
g NUMBER;
out_line VARCHAR2(2000);
 
CURSOR results_cur IS
SELECT
a,
b,
c,
d,
e,
f,
g
FROM
results
ORDER BY
a,b,c,d,e,f,g;
 
results_rec results_cur%ROWTYPE;
 
solutions NUMBER;
uorn VARCHAR2(2000);
BEGIN
solutions := 0;
DELETE FROM allints;
DELETE FROM results;
FOR i IN lo..hi LOOP
INSERT INTO allints VALUES (i);
END LOOP;
COMMIT;
 
IF uniq = TRUE THEN
INSERT INTO results
SELECT
a.v a,
b.v b,
c.v c,
d.v d,
e.v e,
f.v f,
g.v g
FROM
allints a, allints b, allints c,allints d,
allints e, allints f, allints g
WHERE
a.v NOT IN (b.v,c.v,d.v,e.v,f.v,g.v) AND
b.v NOT IN (c.v,d.v,e.v,f.v,g.v) AND
c.v NOT IN (d.v,e.v,f.v,g.v) AND
d.v NOT IN (e.v,f.v,g.v) AND
e.v NOT IN (f.v,g.v) AND
f.v NOT IN (g.v) AND
a.v = c.v + d.v AND
g.v = d.v + e.v AND
b.v = e.v + f.v - c.v
ORDER BY
a,b,c,d,e,f,g;
uorn := ' unique solutions in ';
ELSE
INSERT INTO results
SELECT
a.v a,
b.v b,
c.v c,
d.v d,
e.v e,
f.v f,
g.v g
FROM
allints a, allints b, allints c,allints d,
allints e, allints f, allints g
WHERE
a.v = c.v + d.v AND
g.v = d.v + e.v AND
b.v = e.v + f.v - c.v
ORDER BY
a,b,c,d,e,f,g;
uorn := ' non-unique solutions in ';
END IF;
COMMIT;
 
OPEN results_cur;
LOOP
FETCH results_cur INTO results_rec;
EXIT WHEN results_cur%notfound;
a := results_rec.a;
b := results_rec.b;
c := results_rec.c;
d := results_rec.d;
e := results_rec.e;
f := results_rec.f;
g := results_rec.g;
 
solutions := solutions + 1;
IF show = TRUE THEN
out_line := TO_CHAR(a) || ' ';
out_line := out_line || ' ' || TO_CHAR(b) || ' ';
out_line := out_line || ' ' || TO_CHAR(c) || ' ';
out_line := out_line || ' ' || TO_CHAR(d) || ' ';
out_line := out_line || ' ' || TO_CHAR(e) || ' ';
out_line := out_line || ' ' || TO_CHAR(f) ||' ';
out_line := out_line || ' ' || TO_CHAR(g);
END IF;
 
DBMS_OUTPUT.put_line(out_line);
END LOOP;
CLOSE results_cur;
out_line := TO_CHAR(solutions) || uorn;
out_line := out_line || TO_CHAR(lo) || ' to ' || TO_CHAR(hi);
DBMS_OUTPUT.put_line(out_line);
 
END;
/
 

Output

SQL> execute foursquares(1,7,TRUE,TRUE);
3  7  2  1  5  4  6                                                             
4  5  3  1  6  2  7                                                             
4  7  1  3  2  6  5                                                             
5  6  2  3  1  7  4                                                             
6  4  1  5  2  3  7                                                             
6  4  5  1  2  7  3                                                             
7  2  6  1  3  5  4                                                             
7  3  2  5  1  4  6                                                             
8 unique solutions in 1 to 7                                                    

PL/SQL procedure successfully completed.

SQL> execute foursquares(3,9,TRUE,TRUE);
7  8  3  4  5  6  9                                                             
8  7  3  5  4  6  9                                                             
9  6  4  5  3  7  8                                                             
9  6  5  4  3  8  7                                                             
4 unique solutions in 3 to 9                                                    

PL/SQL procedure successfully completed.

SQL> execute foursquares(0,9,FALSE,FALSE);
2860 non-unique solutions in 0 to 9                                             

PL/SQL procedure successfully completed.

Python[edit]

 
import itertools
 
def all_equal(a,b,c,d,e,f,g):
return a+b == b+c+d and a+b == d+e+f and a+b == f+g
 
def foursquares(lo,hi,unique,show):
solutions = 0
if unique:
uorn = "unique"
citer = itertools.combinations(range(lo,hi+1),7)
else:
uorn = "non-unique"
citer = itertools.combinations_with_replacement(range(lo,hi+1),7)
 
for c in citer:
for p in set(itertools.permutations(c)):
if all_equal(*p):
solutions += 1
if show:
print str(p)[1:-1]
 
print str(solutions)+" "+uorn+" solutions in "+str(lo)+" to "+str(hi)
print
 

Output

foursquares(1,7,True,True)
4, 5, 3, 1, 6, 2, 7
3, 7, 2, 1, 5, 4, 6
5, 6, 2, 3, 1, 7, 4
4, 7, 1, 3, 2, 6, 5
6, 4, 5, 1, 2, 7, 3
7, 3, 2, 5, 1, 4, 6
7, 2, 6, 1, 3, 5, 4
6, 4, 1, 5, 2, 3, 7
8 unique solutions in 1 to 7


foursquares(3,9,True,True)
7, 8, 3, 4, 5, 6, 9
9, 6, 4, 5, 3, 7, 8
8, 7, 3, 5, 4, 6, 9
9, 6, 5, 4, 3, 8, 7
4 unique solutions in 3 to 9


foursquares(0,9,False,False)
2860 non-unique solutions in 0 to 9

Faster solution without itertools

 
def foursquares(lo,hi,unique,show):
 
def acd_iter():
"""
Iterates through all the possible valid values of
a, c, and d.
 
a = c + d
"""

for c in range(lo,hi+1):
for d in range(lo,hi+1):
if (not unique) or (c <> d):
a = c + d
if a >= lo and a <= hi:
if (not unique) or (c <> 0 and d <> 0):
yield (a,c,d)
 
def ge_iter():
"""
Iterates through all the possible valid values of
g and e.
 
g = d + e
"""

for e in range(lo,hi+1):
if (not unique) or (e not in (a,c,d)):
g = d + e
if g >= lo and g <= hi:
if (not unique) or (g not in (a,c,d,e)):
yield (g,e)
 
def bf_iter():
"""
Iterates through all the possible valid values of
b and f.
 
b = e + f - c
"""

for f in range(lo,hi+1):
if (not unique) or (f not in (a,c,d,g,e)):
b = e + f - c
if b >= lo and b <= hi:
if (not unique) or (b not in (a,c,d,g,e,f)):
yield (b,f)
 
solutions = 0
acd_itr = acd_iter()
for acd in acd_itr:
a,c,d = acd
ge_itr = ge_iter()
for ge in ge_itr:
g,e = ge
bf_itr = bf_iter()
for bf in bf_itr:
b,f = bf
solutions += 1
if show:
print str((a,b,c,d,e,f,g))[1:-1]
if unique:
uorn = "unique"
else:
uorn = "non-unique"
 
print str(solutions)+" "+uorn+" solutions in "+str(lo)+" to "+str(hi)
print
 
 

Output

foursquares(1,7,True,True)
4, 7, 1, 3, 2, 6, 5
6, 4, 1, 5, 2, 3, 7
3, 7, 2, 1, 5, 4, 6
5, 6, 2, 3, 1, 7, 4
7, 3, 2, 5, 1, 4, 6
4, 5, 3, 1, 6, 2, 7
6, 4, 5, 1, 2, 7, 3
7, 2, 6, 1, 3, 5, 4
8 unique solutions in 1 to 7


foursquares(3,9,True,True)
7, 8, 3, 4, 5, 6, 9
8, 7, 3, 5, 4, 6, 9
9, 6, 4, 5, 3, 7, 8
9, 6, 5, 4, 3, 8, 7
4 unique solutions in 3 to 9


foursquares(0,9,False,False)
2860 non-unique solutions in 0 to 9

REXX[edit]

fast version[edit]

This REXX version is faster than the more idiomatic version, but is longer (statement-wise) and
a bit easier to read (visualize).

/*REXX pgm solves the 4-rings puzzle,  where letters represent unique (or not) digits). */
arg LO HI unique show . /*the ARG statement capitalizes args.*/
if LO=='' | LO=="," then LO=1 /*Not specified? Then use the default.*/
if HI=='' | HI=="," then HI=7 /* " " " " " " */
if unique=='' | unique==',' | unique=='UNIQUE' then unique=1 /*unique letter solutions*/
else unique=0 /*non-unique " */
if show=='' | show==',' | show=='SHOW' then show=1 /*noshow letter solutions*/
else show=0 /* show " " */
w=max(3, length(LO), length(HI) ) /*maximum width of any number found. */
bar=copies('═', w) /*define a horizontal bar (for title). */
times=HI - LO + 1 /*calculate number of times to loop. */
#=0 /*number of solutions found (so far). */
do a=LO for times
do b=LO for times
if unique then if b==a then iterate
do c=LO for times
if unique then do; if c==a then iterate
if c==b then iterate
end
do d=LO for times
if unique then do; if d==a then iterate
if d==b then iterate
if d==c then iterate
end
do e=LO for times
if unique then do; if e==a then iterate
if e==b then iterate
if e==c then iterate
if e==d then iterate
end
do f=LO for times
if unique then do; if f==a then iterate
if f==b then iterate
if f==c then iterate
if f==d then iterate
if f==e then iterate
end
do g=LO for times
if unique then do; if g==a then iterate
if g==b then iterate
if g==c then iterate
if g==d then iterate
if g==e then iterate
if g==f then iterate
end
sum=a+b
if f+g\==sum then iterate
if b+c+d\==sum then iterate
if d+e+f\==sum then iterate
#=# + 1 /*bump the count of solutions.*/
if #==1 then call align 'a', 'b', 'c', 'd', 'e', 'f', 'g'
if #==1 then call align bar, bar, bar, bar, bar, bar, bar
call align a, b, c, d, e, f, g
end /*g*/
end /*f*/
end /*e*/
end /*d*/
end /*c*/
end /*b*/
end /*a*/
say
_= ' non-unique'
if unique then _= ' unique '
say # _ 'solutions found.'
exit /*stick a fork in it, we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
align: parse arg a1,a2,a3,a4,a5,a6,a7
if show then say left('',9) center(a1,w) center(a2,w) center(a3,w) center(a4,w),
center(a5,w) center(a6,w) center(a7,w)
return

output   when using the default inputs:     1   7

           a   b   c   d   e   f   g
          ═══ ═══ ═══ ═══ ═══ ═══ ═══
           3   7   2   1   5   4   6
           4   5   3   1   6   2   7
           4   7   1   3   2   6   5
           5   6   2   3   1   7   4
           6   4   1   5   2   3   7
           6   4   5   1   2   7   3
           7   2   6   1   3   5   4
           7   3   2   5   1   4   6

8  unique  solutions found.

output   when using the input of:     3   9

           a   b   c   d   e   f   g
          ═══ ═══ ═══ ═══ ═══ ═══ ═══
           7   8   3   4   5   6   9
           8   7   3   5   4   6   9
           9   6   4   5   3   7   8
           9   6   5   4   3   8   7

4  unique  solutions found.

output   when using the input of:     0   9   non-unique   noshow

2860  non-unique solutions found.

idiomatic version[edit]

This REXX version is slower than the faster version   (because of the multiple   if   clauses.

Note that the REXX language doesn't have short-circuits   (when executing multiple clauses in   if   (and other)   statements.

/*REXX pgm solves the 4-rings puzzle,  where letters represent unique (or not) digits). */
arg LO HI unique show . /*the ARG statement capitalizes args.*/
if LO=='' | LO=="," then LO=1 /*Not specified? Then use the default.*/
if HI=='' | HI=="," then HI=7 /* " " " " " " */
if unique=='' | unique==',' | unique=='UNIQUE' then u=1 /*unique letter solutions*/
else u=0 /*non-unique " */
if show=='' | show==',' | show=='SHOW' then show=1 /*noshow letter solutions*/
else show=0 /* show " " */
w=max(3, length(LO), length(HI) ) /*maximum width of any number found. */
bar=copies('═', w) /*define a horizontal bar (for title). */
times=HI - LO + 1 /*calculate number of times to loop. */
#=0 /*number of solutions found (so far). */
do a=LO for times
do b=LO for times; if u then if b==a then iterate
do c=LO for times; if u then if c==a|c==b then iterate
do d=LO for times; if u then if d==a|d==b|d==c then iterate
do e=LO for times; if u then if e==a|e==b|e==c|e==d then iterate
do f=LO for times; if u then if f==a|f==b|f==c|f==d|f==e then iterate
do g=LO for times; if u then if g==a|g==b|g==c|g==d|g==e|g==f then iterate
sum=a+b
if f+g==sum & b+c+d==sum & d+e+f==sum then #=#+1 /*bump #.*/
else iterate /*a no-go*/
#=# + 1 /*bump count of solutions.*/
if #==1 then call align 'a', 'b', 'c', 'd', 'e', 'f', 'g'
if #==1 then call align bar, bar, bar, bar, bar, bar, bar
call align a, b, c, d, e, f, g
end /*g*/ /*for 1st time, show title*/
end /*f*/
end /*e*/
end /*d*/
end /*c*/
end /*b*/
end /*a*/
say
_= ' non-unique'
if u then _= ' unique '
say # _ 'solutions found.'
exit /*stick a fork in it, we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
align: parse arg a1,a2,a3,a4,a5,a6,a7
if show then say left('',9) center(a1,w) center(a2,w) center(a3,w) center(a4,w),
center(a5,w) center(a6,w) center(a7,w)
return

output   is identical to the faster REXX version.

Ruby[edit]

def four_squares(low, high, unique=true, show=unique)
f = -> (a,b,c,d,e,f,g) {[a+b, b+c+d, d+e+f, f+g].uniq.size == 1}
if unique
uniq = "unique"
solutions = [*low..high].permutation(7).select{|ary| f.call(*ary)}
else
uniq = "non-unique"
solutions = [*low..high].repeated_permutation(7).select{|ary| f.call(*ary)}
end
if show
puts " " + [*"a".."g"].join(" ")
solutions.each{|ary| p ary}
end
puts "#{solutions.size} #{uniq} solutions in #{low} to #{high}"
puts
end
 
[[1,7], [3,9]].each do |low, high|
four_squares(low, high)
end
four_squares(0, 9, false)
Output:
 a  b  c  d  e  f  g
[3, 7, 2, 1, 5, 4, 6]
[4, 5, 3, 1, 6, 2, 7]
[4, 7, 1, 3, 2, 6, 5]
[5, 6, 2, 3, 1, 7, 4]
[6, 4, 1, 5, 2, 3, 7]
[6, 4, 5, 1, 2, 7, 3]
[7, 2, 6, 1, 3, 5, 4]
[7, 3, 2, 5, 1, 4, 6]
8 unique solutions in 1 to 7

 a  b  c  d  e  f  g
[7, 8, 3, 4, 5, 6, 9]
[8, 7, 3, 5, 4, 6, 9]
[9, 6, 4, 5, 3, 7, 8]
[9, 6, 5, 4, 3, 8, 7]
4 unique solutions in 3 to 9

2860 non-unique solutions in 0 to 9

Scheme[edit]

 
(import (scheme base)
(scheme write)
(srfi 1))
 
;; return all combinations of size elements from given set
(define (combinations size set unique?)
(if (zero? size)
(list '())
(let loop ((base-combns (combinations (- size 1) set unique?))
(results '())
(items set))
(cond ((null? base-combns) ; end, as no base-combinations to process
results)
((null? items) ; check next base-combination
(loop (cdr base-combns)
results
set))
((and unique? ; ignore if wanting list unique
(member (car items) (car base-combns) =))
(loop base-combns
results
(cdr items)))
(else ; keep the new combination
(loop base-combns
(cons (cons (car items) (car base-combns))
results)
(cdr items)))))))
 
;; checks if all 4 sums are the same
(define (solution? a b c d e f g)
(= (+ a b)
(+ b c d)
(+ d e f)
(+ f g)))
 
;; Tasks
(display "Solutions: LOW=1 HIGH=7\n")
(display (filter (lambda (combination) (apply solution? combination))
(combinations 7 (iota 7 1) #t))) (newline)
 
(display "Solutions: LOW=3 HIGH=9\n")
(display (filter (lambda (combination) (apply solution? combination))
(combinations 7 (iota 7 3) #t))) (newline)
 
(display "Solution count: LOW=0 HIGH=9 non-unique\n")
(display (count (lambda (combination) (apply solution? combination))
(combinations 7 (iota 10 0) #f))) (newline)
 
Output:
Solutions: LOW=1 HIGH=7
((4 5 3 1 6 2 7) (6 4 1 5 2 3 7) (3 7 2 1 5 4 6) (7 3 2 5 1 4 6) (4 7 1 3 2 6 5) (7 2 6 1 3 5 4) (5 6 2 3 1 7 4) (6 4 5 1 2 7 3))
Solutions: LOW=3 HIGH=9
((7 8 3 4 5 6 9) (8 7 3 5 4 6 9) (9 6 4 5 3 7 8) (9 6 5 4 3 8 7))
Solution count: LOW=0 HIGH=9 non-unique
2860

Tcl[edit]

This task is a good opportunity to practice metaprogramming in Tcl. The procedure compile_4rings builds a lambda expression which takes values for {a b c d e f g} as parameters and returns true if those values satisfy the specified expressions ($exprs). This approach lets the bytecode compiler optimise our code.

For the final challenge, we vary the code generation a bit in compile_4rings_hard: instead of a lambda taking parameters, this generates a nested loop that searches exhaustively through the possible values for each variable.

The puzzle can be varied freely by changing the values of $vars and $exprs specified at the top of the script.

set vars {a b c d e f g}
set exprs {
{$a+$b}
{$b+$c+$d}
{$d+$e+$f}
{$f+$g}
}
 
proc permute {xs} {
if {[llength $xs] < 2} {
return $xs
}
set i -1
foreach x $xs {
incr i
set rest [lreplace $xs $i $i]
foreach rest [permute $rest] {
lappend res [list $x {*}$rest]
}
}
return $res
}
 
proc range {a b} {
set a [uplevel 1 [list expr $a]]
set b [uplevel 1 [list expr $b]]
set res {}
while {$a <= $b} {
lappend res $a
incr a
}
return $res
}
 
proc compile_4rings {vars exprs} {
set script "set _ \[[list expr [lindex $exprs 0]]\]\n"
foreach expr [lrange $exprs 1 end] {
append script "if {\$_ != $expr} {return false}\n"
}
append script "return true\n"
list $vars $script
}
 
proc solve_4rings {vars exprs range} {
set lambda [compile_4rings $vars $exprs]
foreach values [permute $range] {
if {[apply $lambda {*}$values]} {
puts " $values"
}
}
}
 
proc compile_4rings_hard {vars exprs values} {
append script "set _ \[[list expr [lindex $exprs 0]]\]\n"
foreach expr [lrange $exprs 1 end] {
append script "if {\$_ != $expr} {continue}\n"
}
append script "incr res\n"
foreach var $vars {
set script [list foreach $var $values $script]
}
set script "set res 0\n$script\nreturn \$res"
list {} $script
}
 
proc solve_4rings_hard {vars exprs range} {
apply [compile_4rings_hard $vars $exprs $range]
}
 
puts "# Combinations of 1..7:"
solve_4rings $vars $exprs [range 1 7]
puts "# Combinations of 3..9:"
solve_4rings $vars $exprs [range 3 9]
puts "# Number of solutions, free over 0..9:"
puts [solve_4rings_hard $vars $exprs [range 0 9]]
Output:
# Combinations of 1..7:
 3 7 2 1 5 4 6
 4 5 3 1 6 2 7
 4 7 1 3 2 6 5
 5 6 2 3 1 7 4
 6 4 1 5 2 3 7
 6 4 5 1 2 7 3
 7 2 6 1 3 5 4
 7 3 2 5 1 4 6
# Combinations of 3..9:
 7 8 3 4 5 6 9
 8 7 3 5 4 6 9
 9 6 4 5 3 7 8
 9 6 5 4 3 8 7
# Number of solutions, free over 0..9:
2860

X86 Assembly[edit]

See 4-rings_or_4-squares_puzzle/X86 Assembly

zkl[edit]

    // unique: No repeated numbers in solution
fcn fourSquaresPuzzle(lo=1,hi=7,unique=True){ //-->list of solutions
_assert_(0<=lo and hi<36);
notUnic:=fcn(a,b,c,etc){ abc:=vm.arglist; // use base 36, any repeated character?
abc.apply("toString",36).concat().unique().len()!=abc.len()
};
s:=List(); // solutions
foreach a,b,c in ([lo..hi],[lo..hi],[lo..hi]){ // chunk to reduce unique
if(unique and notUnic(a,b,c)) continue; // solution space. Slow VM
foreach d,e in ([lo..hi],[lo..hi]){ // -->for d { for e {} }
if(unique and notUnic(a,b,c,d,e)) continue;
foreach f,g in ([lo..hi],[lo..hi]){
if(unique and notUnic(a,b,c,d,e,f,g)) continue;
sqr1,sqr2,sqr3,sqr4 := a+b,b+c+d,d+e+f,f+g;
if((sqr1==sqr2==sqr3) and sqr1==sqr4) s.append(T(a,b,c,d,e,f,g));
}
}
}
s
}
fcn show(solutions,msg){
if(not solutions){ println("No solutions for",msg); return(); }
 
println(solutions.len(),msg," solutions found:");
w:=(1).max(solutions.pump(List,(0).max,"numDigits")); // max width of any number found
fmt:=" " + "%%%ds ".fmt(w)*7; // eg " %1s %1s %1s %1s %1s %1s %1s"
println(fmt.fmt(["a".."g"].walk().xplode()));
println("-"*((w+1)*7 + 1)); // calculate the width of horizontal bar
foreach s in (solutions){ println(fmt.fmt(s.xplode())) }
}
fourSquaresPuzzle() : show(_," unique (1-7)"); println();
fourSquaresPuzzle(3,9) : show(_," unique (3-9)"); println();
fourSquaresPuzzle(5,12) : show(_," unique (5-12)"); println();
println(fourSquaresPuzzle(0,9,False).len(), // 10^7 possibilities
" non-unique (0-9) solutions found.");
Output:
8 unique (1-7) solutions found:
 a b c d e f g 
---------------
 3 7 2 1 5 4 6 
 4 5 3 1 6 2 7 
 4 7 1 3 2 6 5 
 5 6 2 3 1 7 4 
 6 4 1 5 2 3 7 
 6 4 5 1 2 7 3 
 7 2 6 1 3 5 4 
 7 3 2 5 1 4 6 

4 unique (3-9) solutions found:
 a b c d e f g 
---------------
 7 8 3 4 5 6 9 
 8 7 3 5 4 6 9 
 9 6 4 5 3 7 8 
 9 6 5 4 3 8 7 

4 unique (5-12) solutions found:
  a  b  c  d  e  f  g 
----------------------
 11  9  6  5  7  8 12 
 11 10  6  5  7  9 12 
 12  8  7  5  6  9 11 
 12  9  7  5  6 10 11 

2860 non-unique (0-9) solutions found.