'===========================================================================
' Subject: PARTITION PROBLEM                  Date: 11-18-00 (18:49)       
'  Author: David Williams                     Code: QB, QBasic, PDS        
'  Origin: david.williams@capcanada.com     Packet: ALGOR.ABC
'===========================================================================
' Partitn.bas. David Williams and Steve Gunhouse. 2000
' david.williams@ablelink.org
' sgunhouse@juno.com

DECLARE SUB Instructions ()
DECLARE SUB Parts (N%, K$)
DECLARE SUB CondOut (X%(), L%)
DECLARE SUB FullOut (X%(), L%)
DECLARE FUNCTION ProgNum# (N%)
DECLARE FUNCTION FormNum$ (N%)
DECLARE FUNCTION NS$ (X%)
DEFINT B-Z
DEFDBL A
CLS
PRINT "Do you want instructions? (Y/N) ";
DO
  K$ = UCASE$(INKEY$)
LOOP UNTIL K$ = "Y" OR K$ = "N"
PRINT K$
IF K$ = "Y" THEN CALL Instructions
PRINT
DO
 INPUT "Number (1 - 32767)"; A
 A = INT(A)
LOOP UNTIL A >= 1 AND A <= 32767
N = A
PRINT
IF N > 1000 THEN
  PRINT "Upper bound on number of partitions: "; FormNum$(N)
ELSE
  PRINT "Calculating number of partitions..."
  A = ProgNum#(N)
  PRINT "Number of partitions:"; A
END IF
PRINT
IF N > 50 THEN
   PRINT "Partitions would take too long to print."
ELSE
   PRINT "<F>ull printout, <N>eat printout, or <Q>uit? ";
   DO
     K$ = UCASE$(INKEY$)
   LOOP UNTIL K$ = "F" OR K$ = "N" OR K$ = "Q"
   PRINT K$
   PRINT
   IF K$ <> "Q" THEN CALL Parts(N, K$)
END IF
END

SUB CondOut (X(), L)
    J = X(1)
    Y = J
    K = 1
    FOR C = 1 TO L
      IF C < L THEN Y = X(C + 1)
      IF Y <> J OR C = L THEN
        IF K > 1 THEN PRINT NS$(K); "x";
        PRINT NS$(J);
        IF C < L THEN
          PRINT "+";
          J = Y
          K = 1
        ELSE
          PRINT
        END IF
      ELSE
        K = K + 1
      END IF
    NEXT
END SUB

FUNCTION FormNum$ (N)
  A = N
  pi# = 4 * ATN(1)
  P# = (LOG(pi# / SQR(6 * (A - 1))) + pi# * SQR(2 * A / 3)) / LOG(10)
  Q = INT(P#)
  R = INT(.5 + 10 ^ (P# - Q))
  IF R = 10 THEN
    R = 1
    Q = Q + 1
  END IF
  P$ = NS$(R) + " x 10^" + NS$(Q)
  FormNum$ = P$
END FUNCTION

SUB FullOut (X(), L)
     FOR C = 1 TO L - 1
       PRINT NS$(X(C)); "+";
     NEXT
     PRINT NS$(X(L))
END SUB

SUB Instructions
 PRINT
 PRINT "This program tackles the mathematical 'partition' problem."
 PRINT "For any positive integer that the user enters, the program"
 PRINT "calculates in how many different ways the number can be"
 PRINT "expressed as a sum of other integers. Only combinations of"
 PRINT "numbers, not permutations, are counted. If the number of"
 PRINT "partitions is not extremely large, the program then prints them"
 PRINT "out, either in full or in a 'neat' format in which strings of"
 PRINT "identical numbers are condensed into a multiplier and number."
END SUB

FUNCTION NS$ (X)
  Y$ = MID$(STR$(X), 2)
  NS$ = Y$
END FUNCTION

SUB Parts (N, K$)
 DIM X(1 TO N)
 X(1) = 1
 T = N
 L = 1
 DO
   IF X(L) <= T \ 2 THEN
     X(L + 1) = X(L)
     T = T - X(L)
     L = L + 1
   ELSE
     X(L) = T
     IF K$ = "N" THEN
       CALL CondOut(X(), L)
     ELSE
       CALL FullOut(X(), L)
     END IF
     IF L = 1 THEN EXIT DO
     L = L - 1
     T = T + X(L)
     X(L) = X(L) + 1
   END IF
 LOOP
END SUB

FUNCTION ProgNum# (N)
 DIM A(1 TO N)
 M = N \ 2 + 1
 FOR I = M TO N
   A(I) = 1
 NEXT I
 FOR I = M - 1 TO 1 STEP -1
   A(I) = 1
   FOR J = 2 * I TO N
     A(J) = A(J) + A(J - I)
   NEXT J
 NEXT I
 ProgNum# = A(N)
END FUNCTION