95 lines
3.8 KiB
Text
95 lines
3.8 KiB
Text
100H: /* FIND SOME SPHENIC NUMBERS - NUMBERS THAT ARE THE PRODUCT OF THREE */
|
|
/* DISTINCT PRIMES */
|
|
|
|
/* CP/M BDOS SYSTEM CALLS AND I/O ROUTINES */
|
|
BDOS: PROCEDURE( FN, ARG ); DECLARE FN BYTE, ARG ADDRESS; GOTO 5; END;
|
|
PR$CHAR: PROCEDURE( C ); DECLARE C BYTE; CALL BDOS( 2, C ); END;
|
|
PR$STRING: PROCEDURE( S ); DECLARE S ADDRESS; CALL BDOS( 9, S ); END;
|
|
PR$NL: PROCEDURE; CALL PR$CHAR( 0DH ); CALL PR$CHAR( 0AH ); END;
|
|
PR$NUMBER4: PROCEDURE( N );
|
|
DECLARE N ADDRESS;
|
|
DECLARE V ADDRESS, N$STR( 6 ) BYTE, W BYTE;
|
|
V = N;
|
|
W = LAST( N$STR );
|
|
N$STR( W ) = '$';
|
|
N$STR( W := W - 1 ) = '0' + ( V MOD 10 );
|
|
DO WHILE( ( V := V / 10 ) > 0 );
|
|
N$STR( W := W - 1 ) = '0' + ( V MOD 10 );
|
|
END;
|
|
DO WHILE W > 1;
|
|
N$STR( W := W - 1 ) = ' ';
|
|
END;
|
|
CALL PR$STRING( .N$STR( W ) );
|
|
END PR$NUMBER4;
|
|
|
|
/* TASK */
|
|
|
|
DECLARE MAX$SPHENIC LITERALLY '10$000'; /* MAX NUMBER WE WILL CONSIDER */
|
|
DECLARE DCL$SPHENIC LITERALLY '10$001'; /* FOR ARRAY DECLARATION */
|
|
DECLARE CUBE$ROOT$MAX LITERALLY '22'; /* APPROX CUBE ROOT OF MAX */
|
|
DECLARE MAX$PRIME LITERALLY '1667'; /* MAX PRIME NEEDED (10000/2/3) */
|
|
DECLARE DCL$PRIME LITERALLY '1668'; /* FOR ARRAY DECLARATION */
|
|
DECLARE SQ$ROOT$MAX LITERALLY '41'; /* APPROX SQ ROOT OF MAX$PRIME */
|
|
DECLARE FALSE LITERALLY '0';
|
|
DECLARE TRUE LITERALLY '1';
|
|
DECLARE ( I, J, K, P1, P2, P3, P1P2, MAX$P3, COUNT ) ADDRESS;
|
|
|
|
/* SIEVE THE PRIMES TO MAX$PRIME */
|
|
DECLARE PRIME ( DCL$PRIME )BYTE;
|
|
PRIME( 0 ), PRIME( 1 ) = FALSE; PRIME( 2 ) = TRUE;
|
|
DO I = 3 TO LAST( PRIME ) BY 2; PRIME( I ) = TRUE; END;
|
|
DO I = 4 TO LAST( PRIME ) BY 2; PRIME( I ) = FALSE; END;
|
|
DO I = 3 TO SQ$ROOT$MAX;
|
|
IF PRIME( I ) THEN DO;
|
|
DO J = I * I TO LAST( PRIME ) BY I + I; PRIME( J ) = FALSE; END;
|
|
END;
|
|
END;
|
|
|
|
/* SIEVE THE SPHENIC NUMBERS TO MAX$SPHENIC */
|
|
DECLARE SPHENIC ( DCL$SPHENIC )BYTE;
|
|
NEXT$PRIME: PROCEDURE( P$PTR )ADDRESS; /* RETURNS THE NEXT PRIME AFTER P */
|
|
DECLARE P$PTR ADDRESS; /* AND SETS P TO IT */
|
|
DECLARE P BASED P$PTR ADDRESS;
|
|
DECLARE FOUND BYTE;
|
|
FOUND = PRIME( P := P + 1 );
|
|
DO WHILE P < LAST( PRIME ) AND NOT FOUND;
|
|
FOUND = PRIME( P := P + 1 );
|
|
END;
|
|
RETURN P;
|
|
END NEXT$PRIME;
|
|
DO I = 0 TO LAST( SPHENIC ); SPHENIC( I ) = FALSE; END;
|
|
I = 0;
|
|
DO WHILE ( P1 := NEXT$PRIME( .I ) ) < CUBE$ROOT$MAX;
|
|
J = I;
|
|
DO WHILE ( P1P2 := P1 * ( P2 := NEXT$PRIME( .J ) ) ) < MAX$SPHENIC;
|
|
MAX$P3 = MAX$SPHENIC / P1P2;
|
|
K = J;
|
|
DO WHILE ( P3 := NEXT$PRIME( .K ) ) <= MAX$P3;
|
|
SPHENIC( P1P2 * P3 ) = TRUE;
|
|
END;
|
|
END;
|
|
END;
|
|
|
|
/* SHOW THE SPHENIC NUMBERS UP TO 1 000 AND TRIPLETS TO 10 000 */
|
|
CALL PR$STRING( .'SPHENIC NUMBERS UP TO 1 000:$' );CALL PR$NL;
|
|
COUNT = 0;
|
|
DO I = 1 TO 1$000;
|
|
IF SPHENIC( I ) THEN DO;
|
|
CALL PR$CHAR( ' ' );CALL PR$NUMBER4( I );
|
|
IF ( COUNT := COUNT + 1 ) MOD 15 = 0 THEN CALL PR$NL;
|
|
END;
|
|
END;
|
|
CALL PR$NL;
|
|
CALL PR$STRING( .'SPHENIC TRIPLETS UP TO 10 000:$' );CALL PR$NL;
|
|
COUNT = 0;
|
|
DO I = 1 TO 10$000 - 2;
|
|
IF SPHENIC( I ) AND SPHENIC( I + 1 ) AND SPHENIC( I + 2 ) THEN DO;
|
|
CALL PR$STRING( .' ($' );CALL PR$NUMBER4( I );
|
|
CALL PR$STRING( .', $' );CALL PR$NUMBER4( I + 1 );
|
|
CALL PR$STRING( .', $' );CALL PR$NUMBER4( I + 2 );
|
|
CALL PR$CHAR( ')' );
|
|
IF ( COUNT := COUNT + 1 ) MOD 3 = 0 THEN CALL PR$NL;
|
|
END;
|
|
END;
|
|
|
|
EOF
|