| Bytes | Lang | Time | Link |
|---|---|---|---|
| 617 | Wolfram Language Mathematica | 250928T114745Z | 138 Aspe |
| 452 | Python3 | 250924T175757Z | Ajax1234 |
| 050 | JavaScript ES6 | 221110T152917Z | Arnauld |
| 037 | Ruby | 221115T162932Z | G B |
| 014 | 05AB1E | 221110T183832Z | Kevin Cr |
| 019 | Charcoal | 221111T005241Z | Neil |
| 012 | Jelly | 221110T200349Z | Jonathan |
Wolfram Language (Mathematica), 617 bytes
617 bytes, it can be golfed more.
Golfed version. Try it online!
K[j_,p_]:=Abs[Count[#,-1]-Count[#,1]]&@Map[If[j==#,Nothing,Module[{c,w},c=Select[Transpose@{j,#},#[[1]]!=0&&#[[2]]!=0&&#[[1]]!=#[[2]]&];w=Count[c,{a_,b_}/;a<b];If[w<Length@c-w,-1,1]]]&,p]
F[n_]:=Module[{q={{Table[{i,0,0},{i,n}],1}},r=None},While[Length@q>0&&r===None,Module[{s,a,i,c,e,u,v},s=First@q;q=Rest@q;{a,i}=s;If[i>3,Continue[]];c=a[[All,i]];If[FreeQ[c,0],AppendTo[q,{a,i+1}];Continue[]];e=First@First@Position[c,0];u=DeleteCases[c,0];v=Complement[Range@n,u];Do[Module[{A,S},A=a;A[[e,i]]=x;S=DeleteDuplicates@A;If[Length@S==n,If[AllTrue[S,K[#,DeleteCases[S,#]]==0&],r=A;Break[]];AppendTo[q,{A,i}]]],{x,v}]]];r]
Ungolfed version. Try it online!
(* Functional approach for dominance calculation *)
CalculateDominanceScoreFunctional[currentArrangement_, otherArrangements_] :=
Module[{comparisons, dominanceResults},
comparisons = Map[
Function[otherArrangement,
If[currentArrangement == otherArrangement,
Nothing,
Module[{pairwiseComparisons, wins},
pairwiseComparisons = Select[
Transpose[{currentArrangement, otherArrangement}],
#[[1]] != 0 && #[[2]] != 0 && #[[1]] != #[[2]] &
];
wins = Count[pairwiseComparisons, {a_, b_} /; a < b];
If[wins < Length[pairwiseComparisons] - wins, -1, 1]
]
]
],
otherArrangements
];
Abs[Count[comparisons, -1] - Count[comparisons, 1]]
]
(* Find balanced arrangement of size n *)
FindBalancedArrangement[n_] := Module[
{availableNumbers, initialArrangement, queue, result},
availableNumbers = Range[n];
(* Initialize with [[1,0,0], [2,0,0], ..., [n,0,0]] *)
initialArrangement = Table[{i, 0, 0}, {i, availableNumbers}];
queue = {{initialArrangement, 1}};
result = None;
While[Length[queue] > 0 && result === None,
Module[{currentState, currentArrangement, columnIndex, currentColumn,
emptyPositions, usedNumbers, candidateNumbers},
currentState = First[queue];
queue = Rest[queue];
{currentArrangement, columnIndex} = currentState;
(* Skip if we've processed all columns *)
If[columnIndex > 3, Continue[]];
(* Get current column values *)
currentColumn = currentArrangement[[All, columnIndex]];
(* If column is complete, move to next column *)
If[FreeQ[currentColumn, 0],
AppendTo[queue, {currentArrangement, columnIndex + 1}];
Continue[]
];
(* Find first empty position *)
emptyPositions = Position[currentColumn, 0];
If[Length[emptyPositions] == 0, Continue[]];
Module[{emptyIndex, usedInColumn, availableForColumn},
emptyIndex = First[First[emptyPositions]];
usedInColumn = DeleteCases[currentColumn, 0];
availableForColumn = Complement[availableNumbers, usedInColumn];
(* Try each available number *)
Do[
Module[{newArrangement, arrangementSet, isBalanced},
newArrangement = currentArrangement;
newArrangement[[emptyIndex, columnIndex]] = number;
arrangementSet = DeleteDuplicates[Map[List @@ # &, newArrangement]];
(* Check if we have n unique arrangements *)
If[Length[arrangementSet] == n,
(* Test for balance *)
isBalanced = AllTrue[arrangementSet,
Function[arrangement,
Module[{otherArrangements},
otherArrangements = DeleteCases[arrangementSet, arrangement];
CalculateDominanceScoreFunctional[arrangement, otherArrangements] == 0
]
]
];
If[isBalanced, result = newArrangement; Break[]]
];
(* Add to queue for further processing *)
AppendTo[queue, {newArrangement, columnIndex}]
],
{number, availableForColumn}
]
]
]
];
result
]
(* Test function *)
TestBalancedArrangements[] := Module[{testValues, results},
testValues = {1, 3, 5};
Do[
Print["Testing n = ", n, ":"];
Module[{result},
result = FindBalancedArrangement[n];
If[result =!= None,
Print["Found balanced arrangement:"];
Do[
Print[" Row ", i, ": ", result[[i]]],
{i, Length[result]}
],
Print["No balanced arrangement found"]
];
Print[]
],
{n, testValues}
]
]
(* Run tests *)
Print["=== Detailed Version Results ==="];
TestBalancedArrangements[]
Python3, 452 bytes
def K(j,p):
U=[0,0]
for J in p:
if j!=J:
u=[0,0]
for a,b in zip(j,J):
if a and b and a!=b:u[a<b]+=1
U[u[0]<u[1]]+=1
return abs(U[0]-U[1])
def f(n):
T={*range(1,n+1)}
q=[([[i,0,0]for i in T],1)]
for a,i in q:
if i>2:continue
L=[*zip(*a)][i]
if 0 not in L:q+=[(a,i+1)];continue
for r in T-{*L}:
A=eval(str(a));A[L.index(0)][i]=r
if len(V:={*map(tuple,A)})==n:
if 0==any(K(m,V-{m})for m in V):return A
q+=[(A,i)]
JavaScript (ES6), 50 bytes
-5 bytes by porting the formulas used in G B's answer, as suggested by G B.
n=>[...Array(i=n)].map(_=>[i+=n+~n/2,-i-(i%=n),i])
JavaScript (ES6), 55 bytes
-1 thanks to @KevinCruijssen
Returns one perfect non-transitive set, built in a specific way.
n=>[...Array(i=n)].map(_=>[i,(i+~n/2)%n,(4*n-i-++i)%n])
How?
The tuples are built as follows:
First entry: \$n\$ to \$2n-1\$. It would be more obvious to use \$0\$ to \$n-1\$, but it's golfier that way.
Second entry: \$\lfloor n/2\rfloor\$ to \$n-1\$, then \$0\$ to \$\lfloor n/2\rfloor-1\$.
Third entry: \$n-1\$, \$n-3\$, ..., \$0\$, \$n-2\$, \$n-4\$, ..., \$1\$.
Ruby, 43 ... 37 bytes
->n{(1..x=n).map{[x+=n/2,-x-x%=n,x]}}
How?
I wish you didn't ask.
Just trial and error.
05AB1E, 19 14 bytes
-5 bytes porting @Neil's Charcoal answer (which in turn is based on @JonathanAllan's Jelly answer - so make sure to upvote both of them as well).
Lε<DI>;+y·()I%
Try it online or verify all odd inputs up to 15.
Explanation:
L # Push a list in the range [1, (implicit) input-integer]
ε # Map over each integer `y`:
< # Decrease the integer to make it 0-based
D # Duplicate it
I> # Push the input+1
; # Halve it
+ # Add it to the `y-1`
y # Push `y` again
· # Double it
( # Negate it
) # Wrap all three values on the stack into a list
I% # Modulo each by the input
# (after which the list of triplets is output implicitly as result)
Original 19 (18†) bytes brute-force approach:
Ý3ãIã.ΔDδ.SOεD_«O}P
Very slow and will already time out for \$n\geq5\$..
Try it online. or verify 1 and 3...
† If we're allowed to output all possible results for a certain range (e.g. all valid results using integers in the range \$[0,n]\$), it could be 1 byte less by changing the .Δ (find_first) to ʒ (filter), although it'll then become even slower and already times out for \$n=3\$.. try it online.
Explanation:
Ý # Push a list in the range [0, (implicit) input]
3ã # Get a list of all triplets using these values
Iã # Get all input-sized lists using these triplets
.Δ # Find the first list of triplets which is truthy for:
D # Duplicate the current list of triplets
δ # Apply double-vectorized:
.S # Vectorize-compare the triplets
# (e.g. [a,b,c] and [d,e,f] → [C(a,d),C(b,e),C(c,f)], where C(A,B) is a
# compare resulting in -1 if A<B; 0 if A==B; and 1 if A>B)
O # Get the sum of each inner-most triplet comparison
ε # Map over each inner list:
D # Duplicate the list
_ # Check which values are equal to 0 (1 if 0; 0 otherwise)
« # Merge the two lists together
O # Sum the list
}P # After the map: take the product of this list of sums
# (only 1 is truthy in 05AB1E, so I basically check for each triplet-
# comparison [x,y,z] whether x+y+z+(x==0)+(y==0)+(z==0)==1 - meaning there
# is exactly one 0 and an equal amount of 1s and -1s)
# (after which the result is output implicitly)
Charcoal, 19 bytes
NθI﹪Eθ⟦ι⁺ι⊘⊕θ±⊗⊕ι⟧θ
Try it online! Link is to verbose version of code. Outputs the triples @JonathanAllan's answer does (except decremented because Charcoal is 0-indexed), but using a different approach to generating the triples. Explanation:
Nθ Input `n` as an integer
θ Input `n`
E Map over implicit range
⟦ List of
ι Current index
θ Input `n`
⊕ Incremented
⊘ Halved
⁺ Plus
ι Current index
ι Current index
⊕ Incremented
⊗ Doubled
± Negated
⟧ End of list
﹪ Vectorised modulo by
θ Input `n`
I Cast to string
Implicitly print
Jelly, 12 bytes
rCm2ĖṠÞĖF€%o
A monadic Link that accepts an odd, positive integer and yields a list of triples.
Or see a check of the first 21
(checks that there are exactly \$\frac{n-1}{2}\$ others that are greater and exactly \$\frac{n-1}{2}\$ that are less for each triple in the result.).
How?
rCm2ĖṠÞĖF€%o - Link: (odd, positive) integer, n
C - complement (n) -> 1-n
r - (n) inclusive range (that) -> [n,n-1,n-2,...,1,0,-1,...,3-n,2-n,1-n]
m2 - modulo two slice -> [n, n-2,...,1, -1,...,3-n, 1-n]
Ė - enumerate -> [[1,n],[2,n-2],...,[(n+1)/2,1],[(n+3)/2,-1],...,[n-1,3-n],[n,1-n]]
Þ - sort by:
Ṡ - sign (vectorises)
...rotates that list left by (n+1)/2 such that the [(n+3)/2,-1] entry is first
Ė - enumerate
F€ - flatten each
% - modulo (n) (vectorises)
o - logical OR (n) (vectorises) ...replaces zeros with n.