Long Multiplication Program - FREEWARE, listed 06-08-2004

   10  ' longmult.bas - FREEWARE 2004
   20 GOTO 150 ' begin
   30 SAVE"longmult.bas":LIST-120
   40 GOTO 840  ' init sum
   50 GOTO 960  ' group of 3
   60 GOTO 1030 ' add 000 with spacing
   70 GOTO 1180 ' draw lines 1
   80 GOTO 1190 ' draw lines 2
   90 GOTO 1230 ' print results
  100 GOTO 1390 ' count characters
  110 GOTO 1450 ' print sum
  120 GOTO 1970 ' get key input
  130 GOTO 2020 ' test for a valid number

  140 ' begin
  150 CLS
  160 PRINT "****************************************"
  170 PRINT "*  LONG MULTIPRECISION MULTIPLICATION  *"
  180 PRINT "*        rewritten for GW-BASIC        *"
  190 PRINT "*           November 2, 1992           *"
  200 PRINT "*            Eric F. Tchong            *"
  210 PRINT "*        Use only whole numbers        *"
  220 PRINT "*        <Enter>  quits program        *"
  230 PRINT "****************************************"
  240 U=400:T=200:P$="n":KEY OFF:DEFSTR Q:Q=MKI$(0)
  250 DIM A$(U),B$(U),C$(U),D$(U),E$(U),F$(U),N$(T),Z$(T),A(T),B(T),C(T),D(T)
  260 DEF FN L(X)=INT(X/1000000!):DEF FN M(X)=INT((X-FN L(X)*1000000!)/1000)
  270 DEF FN R(X)=X-FN L(X)*1000000!-FN M(X)*1000
  280 FOR Z=0 TO 100:N$(Z)="":NEXT
  290 FOR Z=1 TO 100:N$(Z)=N$(Z-1)+"0":NEXT
  300 PRINT:PRINT
  310 PRINT "Save results in longmult.asc file [y/n] ?"
  320 GOSUB 120
  330 IF EC=89 OR EC=121 THEN COPY=1 ELSE COPY=0
  340 IF COPY THEN OPEN "O",#1,"longmult.asc"

  350 ' Select with or without spacing menu
  360 CLS:PRINT "Do you wish to ..."
  370 PRINT "(1)-----See results with spacing?     12 345 678 901"
  380 PRINT "(2)-----See results without spacing?     12345678901"
  390 PRINT "(3)-----Stop":PRINT:PRINT "1, 2, or 3 ? ";
  400 GOSUB 120:IF CH<1 OR CH>3 THEN 360
  410 CLS
  420 ON CH GOTO 440,1570,2120

  430 ' Results with spacing
  440 CLS:PRINT "Do you wish to ..."
  450 PRINT "(1)-----Multiply two numbers"
  460 PRINT "(2)-----Use product as the multiplicand"
  470 PRINT "(3)-----Use a constant"
  480 PRINT "(4)-----Spacing menu":PRINT:PRINT "1, 2, 3, or 4 ? ";
  490 GOSUB 120:IF CH<1 OR CH>4 THEN 440
  500 CLS
  510 ON CH GOTO 520,520,520,360
  520 INPUT"Multiplicand -1=menu ";VN$:IF VN$="-1" THEN 440
  530 GOSUB 130:IF NG=0 THEN NG=1:GOTO 520 ELSE A$=VN$
  540 INPUT"Multiplier   -1=menu ";VN$:IF VN$="-1" THEN 440
  550 GOSUB 130:IF NG=0 THEN NG=1:GOTO 540 ELSE B$=VN$
  560 PRINT:IF LEN(A$)<LEN(B$) THEN SWAP A$,B$
  570 M1$=A$:M2$=B$:M$=M1$:GOSUB 100:LA=EQ
  580 M$=M2$:GOSUB 100:LB=EQ:A$=M1$:B$=M2$
  590 GOSUB 40:LC=LEN(C$):M3$=F$:M4$=C$ ' f$=1234567 c$=1 234 567
  600 L=(LC-LA)+1: M$=M1$:GOSUB 90:PRINT:IF COPY THEN PRINT #1, ""
  610 L=(LC-LB)+1: M$=M2$:GOSUB 90:PRINT " x":IF COPY THEN PRINT #1, " x"
  620 L=LA:PRINT TAB(1+LC-LA)"";:IF COPY THEN PRINT #1, TAB(1+LC-LA)"";
  630 GOSUB 80
  640 M$=M2$:T=LEN(M$):N=0
  650 FOR A=T TO 1 STEP -1
  660  Z$(J)=""
  670  Z$(A)=MID$(M$,A,1)+N$(N):N=N+1
  680 NEXT:VT=0
  690 FOR A=LEN (M2$)  TO 1 STEP -1
  700  A$=M1$:B$=Z$(A)
  710  IF VAL(B$)=0 THEN 740
  720  GOSUB 40:LB=LEN(C$):L=(LC-LB)+1:PRINT TAB(L) C$:VT=VT+1
  730  IF COPY THEN PRINT #1, TAB(L) C$
  740 NEXT
  750 IF VT=1 AND COPY THEN PRINT #1,"" :GOTO 800
  760 IF VT=1 THEN PRINT :PRINT :GOTO 800
  770 C$=M4$:GOSUB 70:PRINT C$
  780 IF COPY THEN PRINT #1, C$:PRINT #1, ""
  790 PRINT :PRINT
  800 ON CH GOTO 520,810,820
  810 A$=M3$:GOTO 540
  820 A$=M1$:GOTO 540

  830 ' init sum
  840 EQ=0:C(0)=0:D(0)=0:C(1)=0
  850 FOR K=1 TO 200:C(K)=0:D(K)=0:NEXT:L=0:S6=0:GOSUB 50:L1=L2:U1=U2
  860 FOR K=1 TO U1:A(K)=B(K):NEXT:D$=" ":G$=" ":E$=" ":A$=B$
  870 FOR K=1 TO 200:C(K)=0:D(K)=0:NEXT:L=0:S6=0:GOSUB 50
  880 FOR I=1 TO U1
  890  FOR J=1 TO U2:C(I+J)=C(I+J)+A(I)*B(J):NEXT
  900 NEXT:S=U1+U2
  910 FOR K=2 TO S+1:D(K-1)=FN R(C(K))+FN M(C(K-1))+FN L(C(K-2)):NEXT
  920 FOR K=1 TO S:D(K)=D(K)+FN M(D(K-1)):NEXT
  930 FOR K=1 TO S:D(K)=FN R(D(K)):NEXT
  940 FOR K=1 TO S:GOSUB 60:NEXT:RETURN

  950 ' group of 3
  960 L2=LEN(A$):X=INT(L2/3):Y=3*X-L2:IF Y=0 THEN U2=X ELSE U2=X+1
  970 FOR K=1 TO U2
  980  W=L2-3*K+1:IF W<=0 THEN W=1
  990  Z=L2-3*(K-1):IF Z>3 THEN Z=3
 1000  B(K)=VAL(MID$(A$,W,Z))
 1010 NEXT:RETURN

 1020 ' add 000 with spacing
 1030 X=D(S+1-K):S6=X+S6:IF S6=0 THEN RETURN
 1040 D$=STR$(X)
 1050 IF X>99 THEN 1130
 1060 IF X>9 THEN 1110
 1070 IF X>0 THEN 1090
 1080 G$=" 000":E$="000":GOTO 1140
 1090 IF EQ=0 THEN G$=D$:E$=RIGHT$(G$,1) ELSE G$=" 00"+RIGHT$(D$,1):E$=RIGHT$(G$,3)
 1100 GOTO 1140
 1110 IF EQ=0 THEN G$=D$:E$=RIGHT$(G$,2) ELSE G$=" 0"+RIGHT$(D$,2):E$=RIGHT$(G$,3)
 1120 GOTO 1140
 1130 G$=D$:E$=RIGHT$(G$,3)
 1140 IF EQ=0 THEN 1150 ELSE 1160
 1150 C$=G$:F$=E$:EQ=1:RETURN
 1160 C$=C$+G$:F$=F$+E$:RETURN

 1170 ' draw lines
 1180 L=LEN(C$)
 1190 PRINT STRING$(L,"Ä")
 1200 IF COPY THEN PRINT #1, STRING$(L,"-")
 1210 RETURN

 1220 ' print results
 1230 PRINT TAB(L)"";
 1240 Z$="":FOR J=LEN(M$) TO 1 STEP -1:Z$=Z$+MID$(M$,J,1):NEXT
 1250 IF LEN(Z$)/3<>INT(LEN(Z$)/3) THEN PRINT " ";:EQ=EQ+1
 1260 FOR J=LEN(Z$) TO 1 STEP -1
 1270  IF J/3=INT(J/3) THEN PRINT " ";:EQ=EQ+1
 1280  PRINT MID$(Z$,J,1);:EQ=EQ+1
 1290 NEXT

 1300 ' send to diskfile
 1310 IF COPY THEN 1320 ELSE RETURN
 1320 PRINT #1, TAB(L)"";
 1330 IF LEN(Z$)/3<>INT(LEN(Z$)/3) THEN PRINT #1, " ";
 1340 FOR J=LEN(Z$) TO 1 STEP -1
 1350  IF J/3=INT(J/3) THEN PRINT #1, " ";
 1360  PRINT #1, MID$(Z$,J,1);
 1370 NEXT:RETURN

 1380 ' count characters
 1390 EQ=0:IF LEN(M$)/3<>INT(LEN(M$)/3) THEN EQ=EQ+1
 1400 FOR J=LEN(M$) TO 1 STEP -1
 1410  IF J/3=INT(J/3) THEN EQ=EQ+1
 1420  EQ=EQ+1
 1430 NEXT:RETURN

 1440 ' print sum
 1450 PRINT TAB(L)"";
 1460 Z$="":FOR J=LEN(M$) TO 1 STEP -1:Z$=Z$+MID$(M$,J,1):NEXT
 1470 FOR J=LEN(Z$) TO 1 STEP -1
 1480  PRINT MID$(Z$,J,1);
 1490 NEXT

 1500 ' send to diskfile
 1510 IF COPY THEN 1520 ELSE RETURN
 1520 PRINT #1, TAB(L)"";
 1530 FOR J=LEN(Z$) TO 1 STEP -1
 1540  PRINT #1, MID$(Z$,J,1);
 1550 NEXT:RETURN

 1560 ' Results without spacing
 1570 CLS:PRINT "Do you wish to ..."
 1580 PRINT "(1)-----Multiply two numbers"
 1590 PRINT "(2)-----Use product as the multiplicand"
 1600 PRINT "(3)-----Use a constant"
 1610 PRINT "(4)-----Spacing menu":PRINT:PRINT "1, 2, 3, or 4 ? ";
 1620 GOSUB 120:IF CH<1 OR CH>4 THEN 1570
 1630 CLS
 1640 ON CH GOTO 1650,1650,1650,360
 1650 INPUT"Multiplicand -1=menu ";VN$:IF VN$="-1" THEN 1570
 1660 GOSUB 130:IF NG=0 THEN NG=1:GOTO 1650 ELSE A$=VN$
 1670 INPUT"Multiplier   -1=menu ";VN$:IF VN$="-1" THEN 1570
 1680 GOSUB 130:IF NG=0 THEN NG=1:GOTO 1670 ELSE B$=VN$
 1690 PRINT:IF LEN(A$)<LEN(B$) THEN SWAP A$,B$
 1700 M1$=A$:M2$=B$:M$=M1$ : LA=LEN(M$)
 1710 M$=M2$ : LB=LEN(M$) : A$=M1$:B$=M2$
 1720 GOSUB 40:LC=LEN(F$):M3$=F$:M4$=C$ ' f$=1234567 c$=1 234 567
 1730 L=(LC-LA)+1: M$=M1$:GOSUB 110:PRINT:IF COPY THEN PRINT #1, ""
 1740 L=(LC-LB)+1: M$=M2$:GOSUB 110:PRINT " x":IF COPY THEN PRINT #1, " x"
 1750 L=LA:PRINT TAB(1+LC-LA)"";:IF COPY THEN PRINT #1, TAB(1+LC-LA)"";
 1760 GOSUB 80
 1770 M$=M2$:T=LEN(M$):N=0
 1780 FOR A=T TO 1 STEP -1
 1790  Z$(J)=""
 1800  Z$(A)=MID$(M$,A,1)+N$(N):N=N+1
 1810 NEXT:VT=0
 1820 FOR A=LEN (M2$)  TO 1 STEP -1
 1830  A$=M1$:B$=Z$(A)
 1840  IF VAL(B$)=0 THEN 1870
 1850  GOSUB 40:LB=LEN(F$):L=(LC-LB)+1:PRINT TAB(L) F$:VT=VT+1
 1860  IF COPY THEN PRINT #1, TAB(L) F$
 1870 NEXT
 1880 IF VT=1 AND COPY THEN PRINT #1,"" :GOTO 1930
 1890 IF VT=1 THEN PRINT :PRINT :GOTO 1930
 1900 C$=M3$:GOSUB 70:PRINT C$
 1910 IF COPY THEN PRINT #1, C$:PRINT #1, ""
 1920 PRINT:PRINT
 1930 ON CH GOTO 1650,1940,1950
 1940 A$=M3$:GOTO 1670
 1950 A$=M1$:GOTO 1670

 1960 ' get key input
 1970 LSET Q=MKI$(0)
 1980 WHILE CVI(Q)=0:MID$(Q,1)=INKEY$:WEND
 1990 CH=VAL(Q):EC=ASC(Q)
 2000 RETURN

 2010 ' Test for a valid number
 2020 L=LEN(VN$):TC=0
 2030 IF LEFT$(VN$,1)="0" AND L>1 THEN NG=0:PRINT:BEEP:RETURN
 2040 IF VN$="" THEN 2120
 2050 FOR X=1 TO L
 2060  Z=ASC(MID$(VN$,X,1)):IF MID$(VN$,X,1)="." THEN TC=2:GOTO 2080
 2070  IF Z<48 OR Z>57 THEN NG=0:PRINT:BEEP:RETURN
 2080 NEXT
 2090 IF TC>1 THEN NG=0:PRINT:BEEP:RETURN
 2100 NG=1:RETURN

 2110 ' exit
 2120 IF COPY THEN CLOSE #1
 2130 KEY 5,"longmult.bas":KEY 6,CHR$(34)+",a":KEY ON:CLS