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
As with the REXX solution, we use explicit loops to generate the permutations. <lang algol68>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</lang>
- 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
<lang applescript>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 Template: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</lang>
- 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
<lang C>
- 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);
} </lang> 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
<lang lisp> (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)))))
</lang> 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#
<lang fsharp> (* 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}))))
</lang> Then: <lang fsharp> printfn "%d" (Seq.length (N 0 9)) </lang>
- Output:
2860
<lang fsharp> (* 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}))))
</lang> Then: <lang fsharp> 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) </lang>
- 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: <lang fsharp> 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) </lang>
- 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
<lang freebasic>' 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</lang>
- 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
<lang go>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 } </lang>
- 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
By exhaustive search
<lang haskell>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</lang>
- 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
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:
- 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.
- 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 concatMaps, 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.
<lang haskell>import Data.List (delete, sortBy, (\\))
rings :: Bool -> [Int] -> [(Int, Int, Int, Int, Int, Int, Int)] rings u digits =
concatMap -- QUEEN --------------------------------------------------------------------- (\q -> let ts = filter ((<= h) . (q +)) ds bs = if u then delete q ts else ds in concatMap -- LEFT BISHOP AND ITS ROOK ----------------------------------------- (\lb -> let lRook = lb + q in if lRook <= h then let rbs = if u then ts \\ [q, lb, lRook] else ds in concatMap -- RIGHT BISHOP AND ITS 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 concatMap -- KNIGHTS LEFT & RIGHT ------- (\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 ]) ]) ks else []) rbs else []) bs) ds where ds = sortBy (flip compare) digits h = head ds
-- 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])</lang>
- 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
ES6
(Structured search version)
<lang javascript>(() => {
// 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(), ]);
})();</lang>
- 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
<lang scala>// 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)
}</lang>
- 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
There are so few solutions of 7 consecutive numbers, so I used a modified version, to get all the expected solutions at once. <lang pascal>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.</lang>
- 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
<lang perl6>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 = "%{@list.max.chars}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) );</lang>
- 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
<lang Phix>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)</lang>
- 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
<lang plsql> 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; / </lang> 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
<lang Python> 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
</lang> 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 <lang Python> 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
</lang> 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
fast version
This REXX version is faster than the more idiomatic version, but is longer (statement-wise) and
a bit easier to read (visualize).
<lang rexx>/*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</lang>
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
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. <lang rexx>/*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</lang>
output is identical to the faster REXX version.
Ruby
<lang ruby>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)</lang>
- 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
<lang scheme> (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)
</lang>
- 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
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.
<lang Tcl>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]]</lang>
- 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
See 4-rings_or_4-squares_puzzle/X86 Assembly
zkl
<lang zkl> // 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
}</lang> <lang zkl>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.");</lang>
- 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.