g | x | w | all
Bytes Lang Time Link
617Wolfram Language Mathematica250928T114745Z138 Aspe
452Python3250924T175757ZAjax1234
050JavaScript ES6221110T152917ZArnauld
037Ruby221115T162932ZG B
01405AB1E221110T183832ZKevin Cr
019Charcoal221111T005241ZNeil
012Jelly221110T200349ZJonathan

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

Try it online!

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

Try it online!


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

Try it online!

How?

The tuples are built as follows:

Ruby, 43 ... 37 bytes

->n{(1..x=n).map{[x+=n/2,-x-x%=n,x]}}

Try it online!

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)

See here for a step-by-step output.

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.

Try it online!

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.