RogerBW's Blog

Perl Weekly Challenge 123: Ugly Square 28 July 2021

I’ve been doing the Weekly Challenges. The latest involved regular numbers and geometrical squareness testing. (Note that this is open until 1 August 2021.)

TASK #1 › Ugly Numbers

You are given an integer $n >= 1.

Write a script to find the $nth element of Ugly Numbers.

Ugly numbers are those number whose prime factors are 2, 3 or 5. For example, the first 10 Ugly Numbers are 1, 2, 3, 4, 5, 6, 8, 9, 10, 12.

These are also known as Regular numbers. They appear as OEIS #A051037.

So there's obviously a naïve way of doing this: start at 1, test for divisibility by only 2, 3 and 5, and increment the counter if it passes. That's what I did in PostScript. (The inner loop divides repeatedly by, in turn, 2, 3 and 5; if what's left after that is 1, there are no other prime factors.)

/un {
    /c exch def
        1 add
        [ 2 3 5 ] {
            /k exch def
                dup k mod 0 eq {
                    k idiv
                } {
                } ifelse
            } loop
        } forall
        1 eq {
            /c c 1 sub def
        } if
        c 0 le {
        } if
    } loop
} def

But division is slow even for this limited form of factorisation so let's see if we can do better. Actually we can stand directly on the shoulders of giants: Dijkstra used this as an example in A Discipline of Programming (1976). (Chapter 17, "An Exercise Attributed to R. W. Hamming"; it's, hmm, less clear than it might be to a modern reader, but one can still dig out what he's getting at… though this code is based on it rather than a direct implementation, if the latter is even possible.)

I'll use the Raku here, because Perl's syntax for lists of lists is less clear than it might be.

sub un($m) {
  my $n;

We have three FIFO queues: the multiples of 2, of 3, and of 5, each seeded with 1.

  my @s=([1],[1],[1]);
  my @c=(2,3,5);
  for (1..$m) {

The next number in the sequence is the lowest value on any of the queues (which will be in the first position).

    for 0..2 -> $i {

Take that number off each queue on which it appears.

      if (@s[$i][0] == $n) {
        shift @s[$i];

And append to each queue the number multiplied by that queue's coefficient.

      push @s[$i],$n*@c[$i];
  return $n;

So we start with [[1],[1],[1]]. Smallest first value is 1. So we shift that off the front of each queue (leaving them all empty), and push on the back 1 × the coefficient, leaving [[2],[3],[5]].

Next pass. Smallest first value is 2. That comes off the 2-queue, leaving [[],[3],[5]]. Then we push on 2 × the coefficient: [[4],[3,6],[5,10]].

Again. Smallest first value is 3 on the 3-queue. End result is [[4,6],[6,9],[5,10,15]].

Again. Smallest first value is 4 on the 2-queue. End result is [[6,8],[6,9,12],[5,10,15,20]].

Again. Smallest first value is 5 on the 5-queue. End result is [[6,8,10],[6,9,12,15],[10,15,20,25]].

Again. Smallest first value is 6 on the 2- and 3-queues. End result is [[8,10,12],[9,12,15,18],[10,15,20,25,30]].

Again. Smallest first value is 8 on the 2-queue (we don't need to bother doing anything with 7, or any of its multiples). End result is [[10,12,16],[9,12,15,18,24],[10,15,20,25,30,40]].

And so on, gradually increasing the queue size and required storage. There's a slight inefficiency in that some numbers are queued twice, e.g. 3×2 and 2×3. Python and Rust use a special "deque" type for FIFO buffers like this (implementing it as a ring with start and end pointers); in Ruby, Perl and Raku any list will do. (One could doubtless implement a FIFO queue in PostScript, but it would be complex and fiddly.)

TASK #2 › Square Points

You are given coordinates of four points i.e. (x1, y1), (x2, y2), (x3, y3) and (x4, y4).

Write a script to find out if the given four points form a square.

One has to make some assumptions here. Although the examples both trace out the points in an order that produces an outline with no crossovers, I choose to regard the order of the points as insignificant, so that if any ordering forms a square I'll regard it as valid.

The number of orderings of 4 things, i.e. number of ways to trace a path between 4 points visiting each exactly once, is 4×3×2=24. But we don't care about which point we start at (divide by 4), and a reversal will work the same way as a forward trip (divide by 2), leaving only 3 significant orderings that need be considered: ABCD, ABDC, ACBD.

sub sp {
  my $m=shift;

So I'm going to start by just mapping my points into the current order – with an extra copy of the first one on the end, for convenience. (Probably ought to check for receiving a number of points other than 4, really, but the problem definition tells me that 4 is what I'll get. I'm also assuming two-dimensional coordinate space.)

  foreach my $ordering ([0,1,2,3,0],[0,1,3,2,0],[0,2,1,3,0]) {
    my @w=map {$m->[$ordering->[$_%4]]} (0..4);

What is a square? It is a four-sided form with each side of equal length, and each angle of 90 degrees. I'll check for the sides first, because that's computationally cheaper. Basic Pythagoras… but since I only care whether the sides are equal, not how long they are, I skip the square-root stage.

    my @ds;
    foreach my $pp (0..3) {
      push @ds,($w[$pp+1][0]-$w[$pp][0])**2+($w[$pp+1][1]-$w[$pp][1])**2;

List::MoreUtils gives me an all-in-one function to calculate maximum and minimum in the same operation; the alternative would be if (min(@t) != max(@t)), which I used in some of the other languages. (In Rust, float types are by design not directly sortable because of the possibility of NaN, which leads to some extra fiddle.)

    my @t=minmax(@ds);
    if ($t[0] != $t[1]) {

OK, all the sides are equal. Now how about the corners? First of all I'll get a set of angles for each side relative to the X axis. A good atan2 function will probably not fail in the case where x==0, but since I'm checking for x==y==0 anyway…

    my @angles;
    foreach my $pp (0..3) {
      my @delta=map {$w[$pp+1][$_]-$w[$pp][$_]} (0,1);
      my $angle;
      if ($delta[0]==0) {
        if ($delta[1]==0) {     # coincident points
          return 0;
      } else {
      push @angles,$angle;
    push @angles,$angles[0];

Now I want a set of deltas, i.e. the angle between each successive pair of sides. (Wrapping the angle to be positive, since I'm checking equality.)

    my $good=1;
    my @deltas=map {($angles[$_+1]-$angles[$_]+360)%360} (0..3);

The first one must be 90 or 270. (We might be traversing the square clockwise or anticlockwise.)

    if ($deltas[0]!=90 && $deltas[0] != 270) {
    } else {

The others must each be the same as the first one.

      foreach my $di (1..3) {
        if ($deltas[$di] != $deltas[0]) {

If all the deltas were valid, $good is still 1 and we can return a successful result.

    return $good;
  return 0;

This is doing floating-point equality testing, which is of course a sin against von Neumann. At least for the test cases, it seems to work, though; if it didn't, I'd define an "equal-ish" function allowing for an arbitrary level of error.

I added two more coordinate sets for testing: a square with sides set at 45 degrees to the axes, so that you can't just check for corners with matching coordinate values, and a rhombus with all four sides of equal length but non-right angles.

Full code on github.

  1. Posted by Paul Blackwell at 11:59am on 28 July 2021

    Just a gut feeling - haven't sat down and thought about it - but it feels like you should be able to speed up the 'angle' part of the calculation quite a bit by just checking explicitly for orthogonality, rather than calculating the angle and seeing if it's appropriate.

  2. Posted by RogerBW at 12:06pm on 28 July 2021

    Probably, yes – side 1's x/y should match side 2's y/x and so on, without going through the atan2 step.

  3. Posted by RogerBW at 03:14pm on 02 August 2021

    Part 1: probably a more Dijkstra-like approach is to use multiple pointers (for 2, 3, 5) into a single list. Many people factored; some built every combination to an upper bound. (There's also a solution in Mark-Jason Dominus' Higher Order Perl.)

    Part 2: even cleaner than Paul's suggestion, simply check for the opposed diagonals being of equal length!

    One might optimise further by removing the multiple orderings, taking the six squared distances between all possible pairs (0→[1,2,3], 1→[2,3], 2→[3]), and confirming that in a sorted list of those values d[0]==d[3] and d[4]==d[5].

    sub sp {
      my $m=shift;
      my @ds;
      foreach my $a (0..2) {
        foreach my $b ($a+1..3) {
          push @ds,($m->[$b][0]-$m->[$a][0])**2+($m->[$b][1]-$m->[$a][1])**2;
      @ds=sort {$a <=> $b} @ds;
      if ($ds[0]==$ds[3] && $ds[4]==$ds[5]) {
        return 1;
      return 0;

Comments on this post are now closed. If you have particular grounds for adding a late comment, comment on a more recent post quoting the URL of this one.

Tags 1920s 1930s 1940s 1950s 1960s 1970s 1980s 1990s 2000s 2010s 3d printing action advent of code aeronautics aikakirja anecdote animation anime army astronomy audio audio tech aviation base commerce battletech beer boardgaming book of the week bookmonth chain of command children chris chronicle church of no redeeming virtues cold war comedy computing contemporary cornish smuggler cosmic encounter coup covid-19 crime crystal cthulhu eternal cycling dead of winter doctor who documentary drama driving drone ecchi economics en garde espionage essen 2015 essen 2016 essen 2017 essen 2018 essen 2019 essen 2022 essen 2023 existential risk falklands war fandom fanfic fantasy feminism film firefly first world war flash point flight simulation food garmin drive gazebo genesys geocaching geodata gin gkp gurps gurps 101 gus harpoon historical history horror hugo 2014 hugo 2015 hugo 2016 hugo 2017 hugo 2018 hugo 2019 hugo 2020 hugo 2021 hugo 2022 hugo 2023 hugo 2024 hugo-nebula reread in brief avoid instrumented life javascript julian simpson julie enfield kickstarter kotlin learn to play leaving earth linux liquor lovecraftiana lua mecha men with beards mpd museum music mystery naval noir non-fiction one for the brow opera parody paul temple perl perl weekly challenge photography podcast politics postscript powers prediction privacy project woolsack pyracantha python quantum rail raku ranting raspberry pi reading reading boardgames social real life restaurant reviews romance rpg a day rpgs ruby rust scala science fiction scythe second world war security shipwreck simutrans smartphone south atlantic war squaddies stationery steampunk stuarts suburbia superheroes suspense television the resistance the weekly challenge thirsty meeples thriller tin soldier torg toys trailers travel type 26 type 31 type 45 vietnam war war wargaming weather wives and sweethearts writing about writing x-wing young adult
Special All book reviews, All film reviews
Produced by aikakirja v0.1