12
\$\begingroup\$

A polyomino with \$n\$ cells is a shape consisting of \$n\$ equal squares connected edge to edge.
No free polyomino is the rotation, translation or reflection (or a combination of these transformations, i.e. an isometry) of another (they're equal).
The sequence of free polyominoes with \$n\$ cells is as follows:

1, 1, 1, 2, 5, 12, 35, 108, 369, 1285, ...

Polyominoes image

Specifications

  • \$n=0\$ (1) may be excluded
  • This is A000105
  • Standard rules: you may output the \$n^{th}\$ term, all terms up to the \$n\$ terms or the entire sequence
  • This is , so the shortest answer wins
\$\endgroup\$
1
  • 1
    \$\begingroup\$ Related (one-sided instead of free) \$\endgroup\$
    – Arnauld
    Apr 5, 2023 at 10:37

5 Answers 5

5
\$\begingroup\$

JavaScript (ES10), 259 bytes

For now, this is just a slightly modified version of my answer to this other challenge so that reflections are discarded. Supports \$n=0\$.

f=(n,m=[...o=Array(w=n)],i=c=0)=>n?m.map((r,y)=>m.map((_,x,[...m])=>!i|1<<x&~r&(m[y+1]|r/2|r*2)&&f(n-1,m,m[y]|=1<<x)))|c:[...3/64+''].some(k=>o[M=(k^6||m.reverse(),m=m.map(a=(_,y)=>m.map(b=(v,x)=>a|=b|=(v>>y&1)<<w+~x)|b)).flatMap(v=>v/(a&-a)||[])])?0:o[M]=++c

Try it online!

\$\endgroup\$
3
\$\begingroup\$

05AB1E, 73 bytes

Should have been 1 byte less by replacing })}€ê with }){}, but the many nested maps/loops cause a bug in 05AB1E here (})ê} and })}€{ also doesn't work strangely enough..)

1ÝInãʒOQiyƶIô©Δ2Fø0δ.ø}2Fø€ü3}®Ā*εεÅsyøÅsM}}}˜Ùg<]εIô2Føʒà}}4FDíDø})}€êÙg

Basically the exact same approach as my answer for the related challenge, but with a single added Duplicate (in step 4) to also remove reflections in addition to the rotations.

Extremely slow brute-force, so is only able to output up to \$a(4)\$ on TIO.

Try it online or verify the first few results.

Explanation:
Also mostly a copy-paste from my answer of the related challenge, except for step 4.

Step 1: Create all possible \$n^2\$-sized lists using 0s and 1s, consisting of \$n\$ amount of 1s:

1Ý          # Push pair [0,1]
  In        # Push the squared input
    ã       # Cartesian power
ʒ           # Filter this list of lists by:
   i        #  If
 O          #  the sum of the current list
  Q         #  is equal to the (implicit) input-integer:
            #   Continue with the check in step 2 below
            #  (implicit else: implicitly use the implicit input for the filter;
            #   this is only truthy for edge case n=1, which fails step 2 due to the `ü3`)

Try just this first step online (without trailing i).

Step 2: Filter it further to only keep single polynominos, using a flood-fill approach:

 y          #   Push the current list again
  ƶ         #   Multiply each value by its 1-based index
   Iô       #   Convert the list to an input-by-input block
     ©      #   Store this block in variable `®` (without popping)
 Δ          #   Loop until the result no longer changes to flood-fill the matrix:
  2Fø0δ.ø}  #    Add a border of 0s around the matrix:
  2F     }  #     Loop 2 times:
    ø       #      Zip/transpose; swapping rows/columns
      δ     #      Map over each row:
     0 .ø   #       Add a leading/trailing 0
  2Fø€ü3}   #    Convert it into overlapping 3x3 blocks: 
  2F    }   #     Loop 2 times again:
    ø       #      Zip/transpose; swapping rows/columns
     €      #      Map over each inner list:
      ü3    #       Convert it to a list of overlapping triplets
  ®Ā        #    Push matrix `®` and convert all its positive values back to 1s
    *       #    Multiply each 3x3 block by this matrix of 0s/1s (so 0s will remain 0s)
  εεÅsyøÅsM #    Get the largest value from the horizontal/vertical cross of each 3x3 block:
  εε        #     Nested map over each 3x3 block:
    Ås      #       Pop and push its middle row
      y     #       Push the 3x3 block again
       ø    #       Zip/transpose; swapping rows/columns
        Ås  #       Pop and push its middle rows as well (the middle column)
          M #       Push the flattened maximum of the entire (scoped) stack,
            #       which is the flattened maximum of the cross of the current 3x3 block
  }}        #     Close the nested map
 }˜         #   After the flood-fill loop: flatten the block to a list
   Ù        #   Uniquify its values
    g       #   Pop and push its length
     <      #   Decrease it by 1 to account for the 0s
            #   (only 1 is truthy in 05AB1E, so only single islands remain)
]           # Close both the if-statement and filter

Try just the first two steps online.

Step 3: Convert all valid lists to matrices, and slash off any rows/columns of 0s to have the actual polynominos:

ε           # Map over each inner list
 Iô         #  Convert it to an n-by-n block
   2F       #  Inner loop 2 times:
     ø      #   Zip/transpose; swapping rows/columns
      ʒ     #   Filter this list of rows by:
       à    #    Get the maximum of the row (so if it only contains 0s, it'll be removed)
      }     #   Close the filter
    }       #  Close the inner loop

Try just the first three steps online.

Step 4: Remove all duplicated rotations and reflections, by first converting each polynomino to a quartet of its four sorted rotations, then get the reflection of each rotation, and then uniquify that list of octets.

 4F         #  Inner loop 4 times:
   D        #   Duplicate the current polynomino-matrix
    í       #   Reverse each inner row to reflect it
     D      #   Duplicate this new reflected polynomino-matrix again
      ø     #   Zip/transpose the matrix; swapping rows/columns
  })        #  After the loop: wrap the eight rotations + reflections on the stack into a list

            # Explanation if the 05AB1E bug mentioned at the top wasn't present:
    {       #  Sort the octet of rotations + reflections
}Ù          # After the map: uniquify the list of polynomino-rotations/reflections

            # Actual explanation with bug:
}€          # After the map: open a new map:
  ê         #  Sort and uniquify each octet
   Ù        # After the map: uniquify the list of distinct polynomino-orientations/reflections

Try just the first four steps online.

Step 5: Get the amount of unique polynominos left, and output it as result:

g           # Pop and push the length
            # (which is output implicitly as result)
\$\endgroup\$
2
\$\begingroup\$

Python3, 1374 bytes*:

R=range
E=enumerate
def U(b):
 q,s=[b],[b]
 while q:
  b=q.pop(0)
  if(T:=[i[::-1]for i in b])not in s:q+=T,;s+=T,
  if(T:=[*map(list,zip(*[i[::-1]for i in zip(*b)]))])not in s:q+=T,;s+=T,
  if(T:=[*map(list,zip(*b))])not in s:q+=T,;s+=T,
 return s
Z=lambda B:[[j[0]if j else j for j in i]for i in B]
def S(b):
 b=[[*i]for i in b if any(i)]
 if 1-any([*zip(*b)][0]):b=[i[1:]for i in b]
 if 1-any([*zip(*b)][-1]):b=[i[:-1]for i in b]
 return b
C=lambda b:[(x,y)for x,t in E(b)for y,j in E(t)if j]
P=[(1,0),(0,1),(-1,0),(0,-1)]
def M(b):
 t=C(b)
 q=[t.pop(0)]
 while q:
  x,y=q.pop()
  for j,k in P:
   c=(x+j,y+k)
   if c in t:t.remove(c);q+=c,
 return[]==t
V=lambda b,x,y:x*y==0 or len(b)==x or len(b[0])==y
def f(n):
 w=int(n**0.5)
 b=[[[1,0]for _ in R(w)]for _ in R(n//(w or 1))]+[[[1,0]for _ in R(n%(w or 1))]]*(n%(w or 1)>0)
 B=[i+[0]*(max(map(len,b))-len(i))for i in b]
 q,s=[B],[Z(B)]
 while q:
  b=q.pop(0);c=C(b)
  for x,y in c:
   if 0==b[x][y][1]:
    for X,Y in c:
     if(X,Y)!=(x,y):
      for j,k in P:
       J,K=X-j,Y-k;B=eval(str(b));B[x][y]=0
       if(J,K)not in c:
        if K==len(B[0]):B=[i+[0]for i in B]
        if K<0:B=[[0]+i for i in B];K=0
        if J==len(B):B=B+[[0 for _ in B[0]]]
        if J<0:B=[[0 for _ in B[0]]]+B;J=0
        B[J][K]=[1,1]
        if M(S(Z(B)))and all(S(Q)not in s for Q in U(S(Z(B)))):q+=B,;s+=S(Z(B)),
 return len(s)

Try it online!

* Rather long in bytes, but computes solutions up to and including \$n = 9\$ in under 40 seconds on TIO.

\$\endgroup\$
3
  • \$\begingroup\$ 0==any(...) -> 1-any(...) (in function S) \$\endgroup\$
    – The Thonnu
    Apr 6, 2023 at 15:26
  • \$\begingroup\$ q+=[T] -> q+=T, (you have 9 similar occurences where that can be changed) \$\endgroup\$
    – The Thonnu
    Apr 6, 2023 at 15:27
  • 1
    \$\begingroup\$ @TheThonnu Thank you, updated. \$\endgroup\$
    – Ajax1234
    Apr 6, 2023 at 15:53
2
\$\begingroup\$

R, 205 199 bytes

f=\(n,o={},v=0,u=0,`~`=c,`?`=sort,d=-1~1i~1~-1i){for(j in u)F=F+`if`(length(p<-?j~o)<n,f(n,p,v,setdiff((u=u[-1])~j+d,v<-j~v)),2^(-all(apply(Conj(p)%o%d,2,a<-\(x)any(diff(p-?x))))-a(-p)-a(p*1i))/n);F}

Attempt This Online!

A variation of my answer to the related challenge adapted to account for reflections.

Specifically, since the polyominoes \$p\$ are stored as complex numbers, reflections across both axes and diagonals can be represented by their complex conjugates \$Conj(p)\$ multiplied by directional vectors in \$d\$.

\$\endgroup\$
1
\$\begingroup\$

Wolfram Language(Mathematica), 532 496 366 bytes

saved so many bytes thanks to the comment of @Aiden Chow


Modified from the Mathematica code provided by A000105. Really naive. I don't know what I'm doing.


z[p_]:=Union[(#-(Min@Re@p+Min@Im@p*I))&/@p];Q[1]={{0}};Q[n_]:=Module[{f,g,a={}},g=((f=#;({f,#+1,f,#+I,f,#-1,f,#-I}&/@f))&)/@Q[n-1];f=Select[Union[z/@Partition[Flatten@g,n]],Length@#==n&];While[f!={},a={a,Z=f[[1]]};f=Complement[f,Union[z/@Flatten[{#,(#-2Re@#)&/@#}&/@Module[{i=Z,a={Z}},While[(i=I*i)!=Z,a~AppendTo~i];a],1]]]];Partition[Flatten@a,n]];F[n_]:=Length@Q@n

Try it online!


The original Mathematica code looks like

(* In this program by Jaime Rangel-Mondragón, polyominoes are represented as a list of Gaussian integers. *)
polyominoQ[p_List] := And @@ ((IntegerQ[Re[#]] && IntegerQ[Im[#]])& /@ p);
rot[p_?polyominoQ] := I*p;
ref[p_?polyominoQ] := (# - 2 Re[#])& /@ p;
cyclic[p_] := Module[{i = p, ans = {p}}, While[(i = rot[i]) != p, AppendTo[ans, i]]; ans];
dihedral[p_?polyominoQ] := Flatten[{#, ref[#]}& /@ cyclic[p], 1];
canonical[p_?polyominoQ] := Union[(# - (Min[Re[p]] + Min[Im[p]]*I))& /@ p];
allPieces[p_] := Union[canonical /@ dihedral[p]];
polyominoes[1] = {{0}};
polyominoes[n_] := polyominoes[n] = Module[{f, fig, ans = {}}, fig = ((f = #1; ({f, #1 + 1, f, #1 + I, f, #1 - 1, f, #1 - I}&) /@ f)&) /@ polyominoes[n - 1]; fig = Partition[Flatten[fig], n]; f = Select[Union[canonical /@ fig], Length[#1] == n &]; While[f != {}, ans = {ans, First[f]}; f = Complement[f, allPieces[First[f]]]]; Partition[Flatten[ans], n]];
a[n_] := a[n] = Length[ polyominoes[n]];
Table[Print["a(", n, ") = ", a[n]]; a[n], {n, 1, 12}] (* Jean-François Alcover, Mar 24 2015, after Jaime Rangel-Mondragón *)
\$\endgroup\$
4
  • \$\begingroup\$ Changing all the two letter variables to one letter gives 513 bytes \$\endgroup\$
    – Aiden Chow
    Apr 18, 2023 at 4:16
  • \$\begingroup\$ With the semicolons, it looks like you don't actually need the newlines at all, giving 496 bytes \$\endgroup\$
    – Aiden Chow
    Apr 18, 2023 at 4:21
  • \$\begingroup\$ A bunch of golfs here and there: 366 bytes \$\endgroup\$
    – Aiden Chow
    Apr 18, 2023 at 6:36
  • \$\begingroup\$ The only thing I couldn't figure out is how to remove the z function (I have removed all the other functions except for Q and F, as they were unnecessary), maybe someone with more experience with Mathematica could help with that. It seems to boil down to creating an anonymous function, but I don't know much Mathematica so I'm unsure of how to do that. \$\endgroup\$
    – Aiden Chow
    Apr 18, 2023 at 6:37

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.