Is-it possible to exit a double perform:
PERFORM VARYING J FROM 1 BY 1 UNTIL J>10
PERFORM VARYING K FROM 1 BY 1 UNTIL K>3
IF J=2 and K=2
EXIT PERFORM
ELSE
display "LABEL A ===> PROCEDURE NOM_PROC2 "
"J=/"J"/ AND K=/"K"/"
END-IF
END-PERFORM
END-PERFORM
I tried with EXITI PERFORM but it doesn't work for me.
If I understand your question correctly, you want to exit both in-line PERFORMs with the EXIT PERFORM. The following technique should work.
01 SWITCHES.
05 EOL-SW PIC X VALUE 'N'.
88 EOL VALUE 'Y'.
88 NOT-EOL VALUE 'N'.
SET NOT-EOL TO TRUE
PERFORM VARYING J FROM 1 BY 1 UNTIL J>10 OR EOL
PERFORM VARYING K FROM 1 BY 1 UNTIL K>3 OR EOL
IF J=2 and K=2
SET EOL TO TRUE
ELSE
display "LABEL A ===> PROCEDURE NOM_PROC2 "
"J=/"J"/ AND K=/"K"/"
END-IF
END-PERFORM
END-PERFORM
From a previous question you indicated you were transliterating PL/I to COBOL. Just as with spoken and written languages, computer languages have idioms and colloquialisms that don't translate well.
I believe that, logically, this is equivalent.
PERFORM VARYING J FROM 1 BY 1 UNTIL J>2
PERFORM VARYING K FROM 1 BY 1 UNTIL K>2
display "LABEL A ===> PROCEDURE NOM_PROC2 "
"J=/"J"/ AND K=/"K"/"
END-PERFORM
END-PERFORM
How about:
DisplayLabel section.
PERFORM VARYING J FROM 1 BY 1 UNTIL J>10
PERFORM VARYING K FROM 1 BY 1 UNTIL K>3
IF J=2 and K=2
EXIT SECTION
ELSE
display "LABEL A ===> PROCEDURE NOM_PROC2 "
"J=/"J"/ AND K=/"K"/"
END-IF
END-PERFORM
END-PERFORM
exit section.
Call the DisplayLabel section with "perform DisplayLabel"
Use the power of VARYING AFTER performs
perform varying j from 1 by 1 until j > 10
after k from 1 by 1 until k > 3
if j = 2 and k = 2 then
exit perform
else
display "j: " j ", k: " k
end-if
end-perform
prompt$ cobc -xj exitnest.cob
j: 01, k: 01
j: 01, k: 02
j: 01, k: 03
j: 02, k: 01
prompt$
COBOL 2014 (draft) spec has 14.9.27.2
10) At least six AFTER phrases shall be permitted in varying-phrase.
Well, if your original code is PL/I and your remit is not to change the structure of a program if it can be avoided, then use GO TO.
PL/I can exit from a DO with a STOP, RETURN (neither of those is suitable for your situation), LEAVE or GOTO.
LEAVE label
or
GOTO label
You would change either of those to
GO TO label
And have identical results. You don't need to change the existing label even, except for a small difference in syntax, and not even have to think about any code after the label.
If you are able to change the structure of the code you already have two good answers. Brian Tiffin's is the neatest, but cschneid's will be more obvious to the majority of COBOL programmers, who will not know how to "vary" more than once on the same PERFORM.
Related
I am a beginner in COBOL and I am having a little error. When I do a simple statement like ACCEPT (variable) FROM ESCAPE KEY, the program doesn't react to the esc key. I understand that something needs to be done with the compiler but I'm not too sure. I use OpenCobolIDE. Does anyone know what's wrong?
I've searched everywhere but can't find an answer. I leave my Cobol code here although it is very simple.It is basically a menu in Spanish (my native language) in which if you press esc the program will end.
ID DIVISION.
PROGRAM-ID. ALUMAIN.
* Menu principal de la aplicación. ALUMAIN.CBL
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
77 OK PIC X.
77 ESC PIC 99.
88 SALIDA VALUE 27.
PROCEDURE DIVISION.
XXX.
PERFORM UNTIL SALIDA OR OK = "S" OR OK = "s"
DISPLAY "SISTEMA DE ALUMNOS" LINE 1 POSITION 31
ERASE SCREEN
"A ALTAS" LINE 8 POSITION 33
"B BAJAS" LINE 10 POSITION 33
"M MODIFICACIONES" LINE 12 POSITION 33
"C CONSULTAS" LINE 14 POSITION 33
"L LISTADO" LINE 16 POSITION 33
"S SALIR (ESC)" LINE 18 POSITION 33
MOVE 0 TO ESC
ACCEPT OK LINE 25 POSITION 79
ACCEPT ESC FROM ESCAPE KEY
IF OK = "A" OR OK = "a"
CALL "ALUALTAS"
END-IF
IF OK = "B" OR OK = "b"
CALL "ALUBAJA"
END-IF
IF OK = "C" OR OK = "c"
CALL "ALUMNOS"
END-IF
IF OK = "M" OR OK = "m"
CALL "ALUMODI"
END-IF
IF OK = "L" OR OK = "l"
CALL "ALUMLIST"
END-IF
END-PERFORM
STOP RUN.
You very likely would have to go to the runtime settings, enable "run in external terminal" as well as adding the settings COB_SCREEN_EXCEPTIONS=Y and COB_SCREEN_ESC=Y there or do so in the code.
As OCIDE is not maintained any more you likely want to setup a custom compiler to update from the obsolete GnuCOBOL 1.1 or switch to Gix-IDE in general.
As the title implies, I'm doing a software that calculate and verify if the number inserted is a happy number (OR NOT). In COBOL language (For reference about what a happy number is https://mathworld.wolfram.com/HappyNumber.html).
Right now, my code doesnt calculate correctly if the number is happy or not (In the program HEY = Happy and HOY = not happy :C)
My question is, what am i doing wrong in the code? All i need now is to properly detect if its happy or not. Any help is well welcome.
This is my current code:
IDENTIFICATION DIVISION.
PROGRAM-ID. YOUR-PROGRAM-NAME.
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION.
01 num PIC 9(36).
01 addc PIC 9(36).
01 rem PIC 9(36).
01 pow PIC 9(36).
01 toast PIC 9.
01 k PIC 999 VALUE 0.
01 l PIC 9(36).
PROCEDURE DIVISION.
MAIN-PROCEDURE.
DISPLAY"Escribe numero "
ACCEPT num
PERFORM WITH TEST AFTER UNTIL addc = 1
MOVE 0 TO addc
PERFORM WITH TEST AFTER UNTIL num = 0
DIVIDE num BY 10 GIVING num REMAINDER rem
MULTIPLY rem BY rem GIVING pow
MOVE pow TO addc
END-PERFORM
IF addc = 1
MOVE 1 TO toast
ELSE
MOVE addc TO num
ADD 1 TO k
IF k = 20
MOVE 1 TO addc
MOVE 0 TO toast
END-IF
END-IF
END-PERFORM
IF toast = 1
DISPLAY "HEY"
ELSE
DISPLAY "HOY"
END-IF
STOP RUN.
END PROGRAM YOUR-PROGRAM-NAME.
Also, as an extra question, how can i handle numbers above the maximum limit of 36? without using the equivalent of strings and chars in Cobol.
The line:
PERFORM UNTIL num > 0
makes the PERFORM loop to not enter, as num is likely to be greater than 0. What you want to do is to execute the loop, getting all the digits from num UNTIL num is 0.
Besides,
MOVE pow TO addc
should be
ADD pow TO addc
** is used to compute exponentiation values in Cobol. That works OK with "small" numbers for example 5 ** 10 and so on.
Now there is a task where we should find X ** 365 + X ** 364 + X ** 363 + X ** 362 + X ** 361 + ... etc. where X is a decimal number with V9(02).
If ** is used with higher numbers for example 5.00 ** 41 then Truncation of high order digit positions occurs due to the fact that I'm able to keep PIC S9(29)V9(02) COMP-3 MAX (31 digits) with CBL ARITH(EXTEND) option.
Is there a work-around for this / Exponential function?
Is it possible at all on Cobol Enterprise for z/Os?
You could try something like this
The array "big-one" is like having a 1000 byte long numeric field.
i.e. pic 9(1000)
For "5 ** 365", you set mult to 5 and thymes to 365.
Since normal cobol won't support arithmetic on such large numbers, you have to do it yourself.
Start by setting big9(1000) to 1.
This is like having pic 9(1000) value 1.
Then loop "thymes" times thru paragraph "do-mult" that multiplies the digits of big-one by "mult', handling any "karry", by adding it to the intermediate result when calculating on the previous digit.
At the end, the digits of big-one represent the result.
IDENTIFICATION DIVISION.
PROGRAM-ID. cb043.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION.
01 sub1 pic 9(05).
01 big-one.
03 big9 occurs 1000 pic 9(01).
01 mult pic 9(06) value 5.
01 thymes pic 9(03) value 365.
01 sub2 pic 9(05).
01 sub3 pic 9(05).
01 interm pic 9(10).
01 filler redefines interm.
03 karry pic 9(09).
03 rite pic 9.
01 staw pic 9(09).
PROCEDURE DIVISION.
MAINLINE.
******* zeroise the big array
perform varying sub1
from 1 by 1
until sub1 > 1000
move 0 to big9(sub1)
end-perform.
******* make big-one like pic 9(1000) value 1
MOVE 1 to big9(1000).
******* do the multiplication "thymes" times
perform varying sub2
from 1 by 1
until sub2 > thymes
perform do-mult
end-perform.
******* find the first non-zero digit
perform varying sub1
from 1 by 1
until big9(sub1) not = 0
end-perform.
******* display the digits of the result
perform varying sub2
from sub1 by 1
until sub2 > 1000
display sub2 big9(sub2)
end-perform.
stop run.
do-mult.
******* zeroise the stored carry field, "staw"
move 0 to staw.
******* multiply every digit of "big-one"
******* starting at big9(1000) and working backwards to big9(1)
******* the left hand 9 bytes of "interm", represent any carry, as "karry"
******* which is stored in "staw" and is added when the next calculation is
******* done
perform varying sub3
from 1000 by -1
until sub3 = 0
compute interm = (big9(sub3) * mult)
+ staw
move karry to staw
move rite to big9(sub3)
end-perform.
Some problems:
First, 5 ** 365 requires 255 digits.
Second pic S9(29)V9(02) requires that x be somewhat less than 1.2.
However, x is defined as V9(02) (unless something more was intended). The "work-around" is logarithms. FUNCTION LOG10 is available in Enterprise COBOL.
identification division.
program-id. big-exp.
data division.
1 x binary pic v99 value 0.99.
1 log10-of-x comp-2.
1 value-of-x-to-n comp-2.
1 sum-of-values comp-2 value 0.
1 disp-sum pic z(3).9(15).
1 n binary pic 9(3).
procedure division.
begin.
compute log10-of-x = function log10 (x)
perform varying n from 365 by -1
until n = 0
compute value-of-x-to-n = 10 ** (log10-of-x * n)
compute sum-of-values = sum-of-values +
value-of-x-to-n
end-perform
move sum-of-values to disp-sum
display disp-sum
stop run
.
For x = 0.99 the answer is approximately 96.473721519223000.
But note that as x drops below approximately 0.10, underflow may occur.
I'm having some trouble figuring out the logic behind this.
I need to display a report calculating balance, interest and principal per month until the balance is zero.
As an example, if input is months=12, balance=25000, rate=4.5%, output should look like this:
months balance interest principal
1 $25000.00 $93.75 $2,040.71
2 $22,959.29 $86.10 $2,048.36
.......
12 $2,126.53 $7.97 $2,126.49
I'm not sure what to write after DISPLAY col-hdr and before STOP RUN. Any ideas?
IDENTIFICATION DIVISION.
PROGRAM-ID. practice.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 LOANFMT PIC $$$$,$$$,$$$.$$.
01 LOANAMT PIC S9(9)V9(2) VALUE 0.
01 INTRATE PIC S9V9(2) VALUE 0.
01 INTFMT PIC 9.999.
01 NUMMONTHS PIC S9(3) VALUE 0.
01 MONFMT PIC ZZ9.
01 MONCNT PIC S999 VALUE 1.
01 PMT PIC S9(9)V9(2) VALUE 0.
01 PMTFMT PIC $$$$,$$$,$$$.$9.
01 TOTPMT PIC S9(9)V9(2) VALUE 0.
01 TOTFMT PIC $$$$,$$$,$$$.$9.
01 col-hdr.
05 pic x(15) value "Month".
05 pic x(15) value "Balance".
05 pic x(15) value "Interest".
05 pic x(15) value "Principal".
01 Detail-Line.
05 Pic X(2) Value Spaces.
05 DL-MONTH Pic X(999) VALUE 1.
05 Pic X(5) Value Spaces.
05 DL-BALANCE Pic $$$$,$$$,$$$.$9.
05 Pic X(4) Value Spaces.
05 DL-INTEREST Pic $$$$,$$$,$$$.$9.
05 Pic X(4) Value Spaces.
05 DL-PRINCIPAL Pic $$$$,$$$,$$$.$9.
PROCEDURE DIVISION.
000-MAIN SECTION.
DISPLAY "Enter Loan Amount: " WITH NO ADVANCING
ACCEPT LOANAMT
IF 0 > LOANAMT
PERFORM UNTIL LOANAMT > 0
DISPLAY "Loan Amount must be positive"
DISPLAY "Enter Loan Amount: " WITH NO ADVANCING
ACCEPT LOANAMT
end-PERFORM
END-IF
DISPLAY "Enter Annual Interest Rate: " WITH NO ADVANCING
ACCEPT INTRATE
IF 0 > INTRATE
PERFORM UNTIL INTRATE > 0
DISPLAY "Annual Interest Rate must be positive"
DISPLAY "Enter Annual Interest Rate: " WITH
NO ADVANCING
ACCEPT INTRATE
end-PERFORM
END-IF
DISPLAY "Enter Number of Months: " WITH NO ADVANCING
ACCEPT NUMMONTHS
IF 0 > NUMMONTHS
PERFORM UNTIL NUMMONTHS > 0
DISPLAY "Number of Months must be positive"
DISPLAY "Enter Number of Months: " WITH NO
ADVANCING
ACCEPT NUMMONTHS
end-PERFORM
END-IF
DISPLAY SPACE
move LOANAMT TO LOANFMT
move INTRATE TO INTFMT
MOVE NUMMONTHS TO MONFMT
MOVE PMT TO PMTFMT
MOVE TOTPMT TO TOTFMT
DISPLAY col-hdr
100-init.
DL-BALANCE = LOANAMT
DL-INTEREST = LOAN * (INTRATE/NUMMONTHS)
DL-PRINCIPAL = LOANAMT - DL-INTEREST
DISPLAY DETAIL-LINE
PERFORM 200-ADDMONTH UNTIL NUMMONTHS = DL-MONTH
200-ADDMONTH.
ADD 1 TO DL-MONTH
DL-BALANCE = DL-BALANCE - DL-PRINCIPAL
DL-INTEREST = LOAN * (INTRATE/NUMMONTHS)
DL-PRINCIPAL = LOANAMT - DL-INTEREST
DISPLAY DETAIL-LINE.
STOP RUN.
months balance interest principal
1 $25000.00 $93.75 $2,040.71
2 $22,959.29 $86.10 $2,048.36
.......
12 $2,126.53 $7.97 $2,126.49
Firstly, get that sorted out.
months balance interest principal
01 $25,000.00 $93.75 $2,040.71
02 $22,959.29 $86.10 $2,048.36
.......
12 $2,126.53 $7.97 $2,126.49
That looks much more professional, and easy to produce. I don't like the "months" heading, because it is not clear what it means. Some capitalisation would be good as well, but those are up to you. Actual spacing you can sort out as well. In my experience, Principal would always be before Interest, and a figure of the Payment before that. The user will want to see the Payment, not have to work it out, and want to confirm the split of the payment, and visually verify the interest amount.
Maybe it's regional, however.
As Brian noted in a comment, you've had you elbow on the 9 key whilst defining the month in the detail line. Make it PIC 99 or PIC Z9.
You are writing your program as a "fall through" structure. Perhaps that is what you are used to with other languages. Mainly COBOL programs that you would see would have a different structure.
Here is your code re-arranged, also with attention paid to indentation, which is important for the human reader. The spacing I find useful, but is not as mandatory as the indentation:
PROCEDURE DIVISION.
PERFORM GET-AND-VALIDATE-USER-INPUT
PERFORM PROCESS-USER-INPUT
PERFORM PRODUCE-REPORT
GOBACK
.
GET-AND-VALIDATE-USER-INPUT.
PERFORM GET-AND-VALIDATE-LOAN-AMT
PERFORM GET-AND-VALIDATE-INT-RATE
PERFORM GET-AND-VALIDATE-MONTHS
.
GET-AND-VALIDATE-LOAN-AMT.
DISPLAY "Enter Loan Amount: " WITH NO ADVANCING
ACCEPT LOANAMT
IF 0 > LOANAMT
PERFORM UNTIL LOANAMT > 0
DISPLAY "Loan Amount must be positive"
DISPLAY "Enter Loan Amount: "
WITH NO ADVANCING
ACCEPT LOANAMT
end-PERFORM
END-IF
.
GET-AND-VALIDATE-INT-RATE.
DISPLAY "Enter Annual Interest Rate: " WITH NO ADVANCING
ACCEPT INTRATE
IF 0 > INTRATE
PERFORM UNTIL INTRATE > 0
DISPLAY "Annual Interest Rate must be positive"
DISPLAY "Enter Annual Interest Rate: "
WITH NO ADVANCING
ACCEPT INTRATE
end-PERFORM
END-IF
.
GET-AND-VALIDATE-MONTHS.
DISPLAY "Enter Number of Months: " WITH NO ADVANCING
ACCEPT NUMMONTHS
IF 0 > NUMMONTHS
PERFORM UNTIL NUMMONTHS > 0
DISPLAY "Number of Months must be positive"
DISPLAY "Enter Number of Months: "
WITH NO ADVANCING
ACCEPT NUMMONTHS
end-PERFORM
END-IF
.
PROCESS-USER-INPUT.
PERFORM GET-AND-VALIDATE-MONTHS
move LOANAMT TO LOANFMT
move INTRATE TO INTFMT
MOVE NUMMONTHS TO MONFMT
MOVE PMT TO PMTFMT
MOVE TOTPMT TO TOTFMT
.
PRODUCE-REPORT.
DISPLAY SPACE [don't know what you want that for]
DISPLAY col-hdr
PERFORM FORMAT-INITIAL-LINE
PERFORM OUTPUT-DETAIL-LINE
PERFORM FORMAT-MONTHS-TO-END
.
FORMAT-INITIAL-LINE.
DL-BALANCE = LOANAMT
DL-INTEREST = LOAN
* ( INTRATE
/ NUMMONTHS )
DL-PRINCIPAL = LOANAMT
- DL-INTEREST
.
OUTPUT-DETAIL-LINE.
DISPLAY DETAIL-LINE
.
FORMAT-MONTHS-TO-END.
PERFORM NUMMONTHS = DL-MONTH
ADD 1 TO DL-MONTH
DL-BALANCE = DL-BALANCE
- DL-PRINCIPAL
DL-INTEREST = LOAN
* ( INTRATE
/ NUMMONTHS )
DL-PRINCIPAL = LOANAMT
- DL-INTEREST
PERFORM OUTPUT-DETAIL-LINE
END-PERFORM
.
You have assignments. COBOL does not. COBOL has COMPUTE, so you'll need to use that, although MOVE, ADD, SUBTRACT, DIVIDE and MULTIPLY can clarify as well:
FORMAT-INITIAL-LINE.
MOVE LOANAMT TO DL-BALANCE
COMPUTE DL-INTEREST = LOAN
* ( INTRATE
/ NUMMONTHS )
SUBTRACT DL-INTEREST FROM LOANAMT
GIVING DL-PRINCIPAL
.
Note that GIVING. SUBTRACT A FROM B will change the value of B. If you put GIVING C on the end, B will no longer be changed, instead the result will be placed in C. ADD A TO B changes B. ADD A B GIVING C does not (note this time no need for TO, although syntactically it can be there). Ensure you understand what ADD, SUBTRACT, MULTIPLY and DIVIDE can do.
It is possible to only use COMPUTE. Unlike myth, there is no performance penalty in this, but extra human-reader information is lost.
With modern COBOL compilers it is not necessary to start a program with an arbitrary procedure name (either SECTION or paragraph). It has no meaning, at all. So ditch this (unless dictated by tutor/site-standards):
000-MAIN SECTION.
You have things like this:
IF 0 > LOANAMT
And:
PERFORM UNTIL LOANAMT > 0
I understand the point made by cshneid made in a comment, but there is consistency, and there is the fact that COBOL has no assignment statement. An expression in a conditional construct can never cause a change to any field involved in the expression.
IF LOANAMT > 0
Or:
IF LOANAMT GREATER THAN 0
Can be read, by the mythical average COBOL programmer, without pause.
IF 0 < LOANAMT
Is more of a discontinuity. The reader has to stop and think what that means. There is no benefit in doing it that way, and there are disbenefits.
DISPLAY and ACCEPT are the COBOL verbs which vary the most from the COBOL standard, from compiler to compiler. To the COBOL 85 Standard, ACCEPT and DISPLAY are very plain. You are using a compiler with "Extended" ACCEPT and DISPLAY. This may (probably does) allow the entry of negative amounts, and may prevent the entry of non-numeric data, but you need to check the documentation for your compiler. It will be important that the data entered is numeric. It is easier to get a character in the number than to enter a negative value by accident.
From your original code:
100-init.
DL-BALANCE = LOANAMT
DL-INTEREST = LOAN * (INTRATE/NUMMONTHS)
DL-PRINCIPAL = LOANAMT - DL-INTEREST
DISPLAY DETAIL-LINE
PERFORM 200-ADDMONTH UNTIL NUMMONTHS = DL-MONTH
200-ADDMONTH.
ADD 1 TO DL-MONTH
DL-BALANCE = DL-BALANCE - DL-PRINCIPAL
DL-INTEREST = LOAN * (INTRATE/NUMMONTHS)
DL-PRINCIPAL = LOANAMT - DL-INTEREST
DISPLAY DETAIL-LINE.
STOP RUN.
Here, since 100-init is not PERFORMed, the program control will drop through into 200-ADDMONTH. Labels (paragraphs or SECTIONs) are just labels. They can be the target of a PERFORM, a GO TO, or they can be "fallen through" or "dropped into". They are unlike "subroutine" or "function" definitions in other languages you probably know.
So, 100-init will PERFORM 200-ADDMONTH until it is finished with, then it will fall into 200-ADDMONTH again. Never code that deliberately. Each paragraph/SECTION should be self-contained and not rely on the physical location of its content.
If 100-init were PERFORMed, you'd be OK. Sort of. Because you have a STOP RUN in 200-ADDMONTH. When 200-ADDMONTH is executed the first time, the program will stop executing. Not what you want.
I've not considered the logic of your actual calculation, just the methods of it. You have duplicated code, so that could go in another PERFORMed paragraph/SECTION.
Be aware of the difference between a paragraph and a SECTION when they are PERFORMed. A SECTION can (these days does not have to) contain paragraphs. When a SECTION is PERFORMed, control returns to the completed PERFORM before the next SECTION. When a paragraph is PERFORMed, control returns before the next paragraph. Paragraphs cannot contain other paragraphs. To PERFORM a range of paragraphs, THRU will be required on the PERFORM. Unless dictated by tutor/site-standards, avoid coding that. Again, it relies on the physical location of code. Which is bad.
These days, there should be no intrinsic need for SECTIONs, and no need (except diktat) for PERFORM ... THRU ....
Using java, finding the arrangements is pretty easy and computable.
Using COBOL as the programming language, I am finding it difficult to code it off.
PERFORM VARYING I FROM 1 BY 1 UNTIL I=5
COMPUTE X = 5-I
PERFORM VARYING J FROM I BY 1 UNTIL J=X
MOVE WORD(I,1) TO TEMP1.
MOVE WORD(J,1) TO TEMP2.
I have a code sample, I am not sure as it is incomplete and I wonder if I am on the right way of doing it.
This problem can be solved using just about any programming language (including COBOL), with or without recursion. A recursive
solution is trivial, the non-recursive solution is a bit more interesting. Here is a COBOL, non-recursive implementation.
A few observations:
Arrangements may be built iteratively from an empty base case and a list of characters to build the arrangements from.
On each iteration the next character
is taken from the input list and inserted at all possible positions of base cases from the prior iteration. These new strings become the base case for
the next iteration. When the input list becomes empty the base case contains all possible arrangements.
Consider building arrangements of 3 characters this way:
Iteration 0 => Input[a, b, c] introduce []: BaseCases[[]]
Iteration 1 => Input[b, c] introduce [a]: BaseCases[[a]]
Iteration 2 => Input[c] introduce [b]: BaseCases[[b a], [a b]]
Iteration 3 => Input [] introduce [c]: BaseCases[[c b a], [b c a], [b a c], [c b a], [b c a], [a b c]]
Note that the number of strings in the final base case is equal to factorial(length(input)). In the above example three characters
were introduced giving 3! = 6 strings in the final base case.
Since the number of strings to be generated in any given iteration is known at the time of the iteration and that number is
larger than the previous iteration we can use the same array structure to hold the base cases for both iterations at the same time.
This is done by building the new base case starting at the highest subscript and working backwards. The same is done when extracting
base patterns generated on the prior iteration. This explains why subscripting in the following program is done
in reverse order (counting down instead of up).
IDENTIFICATION DIVISION.
PROGRAM-ID ARRANGE.
DATA DIVISION.
WORKING-STORAGE SECTION.
01.
02 ARRANGEMENT-TABLE.
03 ARRANGEMENT PIC X(5) OCCURS 120 TIMES.
01 INPUT-CHARS PIC X(5) VALUE 'abcde'.
01 BASE-ARRANGEMENT PIC X(5).
01 CURR-CHAR PIC X.
01 I PIC S9(4) BINARY.
01 J PIC S9(4) BINARY.
01 K PIC S9(4) BINARY.
01 L PIC S9(4) BINARY.
01 CURR-FACT PIC S9(9) BINARY.
01 PREV-FACT PIC S9(9) BINARY.
01 COMP-FACT PIC S9(9) BINARY.
PROCEDURE DIVISION.
*
* Verify that the Arrangement table is large enough to hold
* all possible arrangements of the letters in INPUT-CHARS.
*
COMPUTE COMP-FACT =
FUNCTION FACTORIAL (LENGTH OF INPUT-CHARS)
IF COMP-FACT > LENGTH OF ARRANGEMENT-TABLE /
LENGTH OF ARRANGEMENT(1)
DISPLAY 'ARRANGEMENT-TABLE is too small.'
GOBACK
END-IF
IF LENGTH OF ARRANGEMENT(1) < LENGTH OF INPUT-CHARS
DISPLAY 'INPUT-CHARS too long for ARRANGEMENT.'
GOBACK
END-IF
IF LENGTH OF BASE-ARRANGEMENT < LENGTH OF ARRANGEMENT(1)
DISPLAY 'BASE-ARRANGEMENT is too small for ARRANGEMENT.'
GOBACK
END-IF
MOVE SPACES TO ARRANGEMENT(1)
DISPLAY 'Starting sequence: ' INPUT-CHARS
*
* Generate all possible arrangements of INPUT-CHARS...
*
* I counts through the set of INPUT-CHARS used in string geneation
* J counts down from arrangements built on previous iteration
* K counts to number of characters in new expanded base case
* L counts down from arrangements to be build in current iteration
*
* CURR-FACT is the factorial of the current iteration number
* PREV-FACT is the factorial of the previous iteration
* CURR-CHAR is the character to add into existing base cases
MOVE 1 TO CURR-FACT
PERFORM VARYING I FROM 1 BY 1
UNTIL I > LENGTH OF INPUT-CHARS
MOVE CURR-FACT TO PREV-FACT
COMPUTE CURR-FACT = PREV-FACT * I
MOVE INPUT-CHARS(I:1) TO CURR-CHAR
MOVE CURR-FACT TO L
PERFORM VARYING J FROM PREV-FACT BY -1
UNTIL J = ZERO
PERFORM VARYING K FROM 1 BY 1
UNTIL K > I
MOVE ARRANGEMENT(J) TO BASE-ARRANGEMENT
PERFORM NEW-ARRANGEMENT
COMPUTE L = L - 1
END-PERFORM
END-PERFORM
END-PERFORM
*
* List generated patters...
*
COMPUTE COMP-FACT =
FUNCTION FACTORIAL(LENGTH OF INPUT-CHARS)
PERFORM VARYING I FROM COMP-FACT BY -1
UNTIL I < 1
DISPLAY ARRANGEMENT(I)
END-PERFORM
GOBACK
.
NEW-ARRANGEMENT.
*
* Build a new character arrangement by placing
* CURR-CHAR into position K of a given
* BASE-ARRANGEMENT
*
MOVE SPACES TO ARRANGEMENT(L)
MOVE CURR-CHAR TO ARRANGEMENT(L)(K:1)
IF K > 1
MOVE BASE-ARRANGEMENT(1:K - 1)
TO ARRANGEMENT(L)(1:K - 1)
END-IF
IF K <= PREV-FACT
MOVE BASE-ARRANGEMENT(K:)
TO ARRANGEMENT(L)(K + 1:)
END-IF
.
Final Note:
If the input string contains repeated characters then some of the patters will be repeated. This solution does not take this "complication" into consideration.
Here is an implementation of Ingo's blueprint (see above) in COBOL. I offer it because it is a different algorithm than the ones that NealB and Bill Woodger provided.
IDENTIFICATION DIVISION.
PROGRAM-ID. PERMUTATION.
* GENERATE PERMUTATIONS FROM A SET OF FIVE ELEMENTS
* WITHOUT USING RECURSION
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION.
01 CHAR-SET PIC X(5) VALUE 'ABCDE'.
01 SOLUTION PIC X(5).
01 SOLUTION-COUNT PIC 999 VALUE ZERO.
01 INDEXES.
02 I PIC 9.
02 J PIC 9.
02 K PIC 9.
02 L PIC 9.
02 M PIC 9.
PROCEDURE DIVISION.
MAIN.
* IGNORED REGULAR INDENTING TO SIMPLIFY CODE
PERFORM VARYING I FROM 1 BY 1 UNTIL I > 5
PERFORM VARYING J FROM 1 BY 1 UNTIL J > 5
IF J NOT = I
PERFORM VARYING K FROM 1 BY 1 UNTIL K > 5
IF K NOT = J AND K NOT = I
PERFORM VARYING L FROM 1 BY 1 UNTIL L > 5
IF L NOT = K AND L NOT = J AND L NOT = I
PERFORM VARYING M FROM 1 BY 1 UNTIL M > 5
IF M NOT = L AND M NOT = K AND M NOT = J AND M NOT = I
ADD 1 TO SOLUTION-COUNT END-ADD
DISPLAY SOLUTION-COUNT ' ' WITH NO ADVANCING
END-DISPLAY
MOVE CHAR-SET(I:1) TO SOLUTION (1:1)
MOVE CHAR-SET(J:1) TO SOLUTION (2:1)
MOVE CHAR-SET(K:1) TO SOLUTION (3:1)
MOVE CHAR-SET(L:1) TO SOLUTION (4:1)
MOVE CHAR-SET(M:1) TO SOLUTION (5:1)
DISPLAY SOLUTION END-DISPLAY
END-IF
END-PERFORM
END-IF
END-PERFORM
END-IF
END-PERFORM
END-IF
END-PERFORM
END-PERFORM
STOP RUN
.
IMHO, you'd need a n-fold nested loop to make the permutations of n elements. The following provides a blueprint:
for i = 1 to 5
for j = 1 to 5 if j != i
for k = 1 to 5 if k != j && k != i
for m = 1 to 5 if m != k && m != j && m != i
for n = 1 to 5 if n != m && n != k && n != j && n != i
solution = (i,j,k,m,n)
This way, you get 120 solutions.
If it is needed, you can then replace the indexes by the actual characters at the respective positions.
To solve it with SQL assumes we have a table with 5 distinct rows:
CREATE NUMBERS (VAL INT PRIMARY KEY);
INSERT INTO NUMBERS VALUES(1);
INSERT INTO NUMBERS VALUES(2);
INSERT INTO NUMBERS VALUES(3);
INSERT INTO NUMBERS VALUES(4);
INSERT INTO NUMBERS VALUES(5);
SELECT VAL I, VAL J, VAL K, VAL M, VAL N FROM NUMBERS WHERE
I <> J
AND K <> I AND K <> J
AND M <> I AND M <> J AND M <> K
AND N <> I AND N <> J AND N <> K AND N <> M;
Not sure if the SQL syntax is right, but you get the idea.
With "value 1" fixed in position one, go through the loop once generating the 24 cobminations.
Then, "making space for it first", place Value 1 in column 2. Then Value 1 in Column 3. Column 4. Column 5.
Or
Take the initial results, that's one set, then "revolve" all the values in the results (1 = 2, 2 = 3, 3 = 4, 4 = 5, 5 = 1). Thats second result set. Do that three more times.
With either, you can include the "full results" from the one iteration to get the "pattern" of 24 results.
As an example, the following can be added to Valdis Grinbergs's code:
In the WORKING-STORAGE SECTION:
01 SAVE-SOLUTION.
02 SAVE-IT PIC X.
02 FILLER PIC X(4).
In the PROCEDURE DIVISION:
Change the first PERFORM to
MOVE 1 TO I
After each SOLUTION is displayed:
PERFORM SOLUTIONS-FOR-REMAINING-VALUES
Which is, for the "column insertion" version:
SOLUTIONS-FOR-REMAINING-VALUES.
MOVE SOLUTION TO SAVE-SOLUTION
MOVE SOLUTION (2:1) TO SOLUTION (1:1)
MOVE SAVE-IT TO SOLUTION (2:1)
ADD 1 TO SOLUTION-COUNT
DISPLAY SOLUTION
MOVE SAVE-SOLUTION TO SOLUTION
MOVE SOLUTION (3:1) TO SOLUTION (1:1)
MOVE SAVE-IT TO SOLUTION (3:1)
ADD 1 TO SOLUTION-COUNT
DISPLAY SOLUTION
MOVE SAVE-SOLUTION TO SOLUTION
MOVE SOLUTION (4:1) TO SOLUTION (1:1)
MOVE SAVE-IT TO SOLUTION (4:1)
ADD 1 TO SOLUTION-COUNT
DISPLAY SOLUTION
MOVE SAVE-SOLUTION TO SOLUTION
MOVE SOLUTION (5:1) TO SOLUTION (1:1)
MOVE SAVE-IT TO SOLUTION (5:1)
ADD 1 TO SOLUTION-COUNT
DISPLAY SOLUTION
.
And for the "repeating transposition" version:
SOLUTIONS-FOR-REMAINING-VALUES.
PERFORM 4 TIMES
MOVE SOLUTION (1:1) TO SAVE-IT
MOVE SOLUTION (2:1) TO SOLUTION (1:1)
MOVE SOLUTION (3:1) TO SOLUTION (2:1)
MOVE SOLUTION (4:1) TO SOLUTION (3:1)
MOVE SOLUTION (5:1) TO SOLUTION (4:1)
MOVE SAVE-IT TO SOLUTION (5:1)
ADD 1 TO SOLUTION-COUNT
DISPLAY SOLUTION
END-PERFORM
.
Of course, the paragraph I've added could be done as a loop, but I want to concentrate on showing what is happening, not on how to write a loop in COBOL.
The two different "solutions" are actually two implementations of the same thing. Once the "pattern" has been established, the other 4/5 of the output can be generated by simply varying the content within the fixed pattern.
The loops in the original code can be worked on.
If, for an actual application, performance is a main requirement, then just realise that the "pattern" is known before a line of code is written. The code just saves you writing 24 results by hand. For performance, and with a small-enough "pattern", just code it out, forget the loops.
And I wouldn't use all the "reference modification" myself, I've just left it there from the original.
Now, two versions without loops.Based on the fact that the "pattern" for the first 24 solutions is known beforehand, and that the remaining solutions (already known, but not needed to be coded in the same way) can easily be derived from that.
Rotating values.
ID DIVISION.
PROGRAM-ID. PROTATE.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 CHAR-SET PIC X(5) VALUE 'ABCDE'.
01 SOLUTION PIC X(5).
01 SOLUTION-COUNT binary PIC 9(4) VALUE ZERO.
01 INDEXES.
02 COLUMN-1 binary PIC 9(4).
02 COLUMN-2 binary PIC 9(4).
02 COLUMN-3 binary PIC 9(4).
02 COLUMN-4 binary PIC 9(4).
02 COLUMN-5 binary PIC 9(4).
02 ICOL-3 binary PIC 9(4).
02 ICOL-4 binary PIC 9(4).
02 ICOL-5 binary PIC 9(4).
01 SAVE-SOLUTION.
02 SAVE-IT PIC X.
02 FILLER PIC X(4).
PROCEDURE DIVISION.
MAIN-para.
MOVE 1 TO COLUMN-1
MOVE 2 TO COLUMN-2
MOVE 3 TO ICOL-3
MOVE 4 TO ICOL-4
MOVE 5 TO ICOL-5
PERFORM SIX-SOLUTIONS
MOVE 3 TO COLUMN-2
MOVE 2 TO ICOL-3
MOVE 4 TO ICOL-4
MOVE 5 TO ICOL-5
PERFORM SIX-SOLUTIONS
MOVE 4 TO COLUMN-2
MOVE 2 TO ICOL-3
MOVE 3 TO ICOL-4
MOVE 5 TO ICOL-5
PERFORM SIX-SOLUTIONS
MOVE 5 TO COLUMN-2
MOVE 2 TO ICOL-3
MOVE 3 TO ICOL-4
MOVE 4 TO ICOL-5
PERFORM SIX-SOLUTIONS
DISPLAY SOLUTION-COUNT
STOP RUN
.
SIX-SOLUTIONS.
MOVE ICOL-3 TO COLUMN-3
MOVE ICOL-4 TO COLUMN-4
MOVE ICOL-5 TO COLUMN-5
PERFORM A-SOLUTION
MOVE ICOL-5 TO COLUMN-4
MOVE ICOL-4 TO COLUMN-5
PERFORM A-SOLUTION
MOVE ICOL-4 TO COLUMN-3
MOVE ICOL-3 TO COLUMN-4
MOVE ICOL-5 TO COLUMN-5
PERFORM A-SOLUTION
MOVE ICOL-5 TO COLUMN-4
MOVE ICOL-3 TO COLUMN-5
PERFORM A-SOLUTION
MOVE ICOL-5 TO COLUMN-3
MOVE ICOL-3 TO COLUMN-4
MOVE ICOL-4 TO COLUMN-5
PERFORM A-SOLUTION
MOVE ICOL-4 TO COLUMN-4
MOVE ICOL-3 TO COLUMN-5
PERFORM A-SOLUTION
.
A-SOLUTION.
MOVE CHAR-SET ( 1 : 1 ) TO SOLUTION ( 1 : 1 )
MOVE CHAR-SET ( COLUMN-2 : 1 ) TO SOLUTION ( 2 : 1 )
MOVE CHAR-SET ( COLUMN-3 : 1 ) TO SOLUTION ( 3 : 1 )
MOVE CHAR-SET ( COLUMN-4 : 1 ) TO SOLUTION ( 4 : 1 )
MOVE CHAR-SET ( COLUMN-5 : 1 ) TO SOLUTION ( 5 : 1 )
PERFORM SOLUTION-READY
PERFORM SOLUTIONS-FOR-REMAINING-VALUES
.
SOLUTIONS-FOR-REMAINING-VALUES.
MOVE SOLUTION TO SAVE-SOLUTION
MOVE SOLUTION ( 2 : 1 ) TO SOLUTION ( 1 : 1 )
MOVE SAVE-IT TO SOLUTION ( 2 : 1 )
PERFORM SOLUTION-READY
MOVE SAVE-SOLUTION TO SOLUTION
MOVE SOLUTION ( 3 : 1 ) TO SOLUTION ( 1 : 1 )
MOVE SAVE-IT TO SOLUTION ( 3 : 1 )
PERFORM SOLUTION-READY
MOVE SAVE-SOLUTION TO SOLUTION
MOVE SOLUTION ( 4 : 1 ) TO SOLUTION ( 1 : 1 )
MOVE SAVE-IT TO SOLUTION ( 4 : 1 )
PERFORM SOLUTION-READY
MOVE SAVE-SOLUTION TO SOLUTION
MOVE SOLUTION ( 5 : 1 ) TO SOLUTION ( 1 : 1 )
MOVE SAVE-IT TO SOLUTION ( 5 : 1 )
PERFORM SOLUTION-READY
.
SOLUTION-READY.
ADD 1 TO SOLUTION-COUNT
DISPLAY SOLUTION
.
Column Inserting:
ID DIVISION.
PROGRAM-ID. PCOLINS.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 CHAR-SET PIC X(5) VALUE 'ABCDE'.
01 SOLUTION PIC X(5).
01 SOLUTION-COUNT binary PIC 9(4) VALUE ZERO.
01 INDEXES.
02 COLUMN-1 binary PIC 9(4).
02 COLUMN-2 binary PIC 9(4).
02 COLUMN-3 binary PIC 9(4).
02 COLUMN-4 binary PIC 9(4).
02 COLUMN-5 binary PIC 9(4).
02 ICOL-3 binary PIC 9(4).
02 ICOL-4 binary PIC 9(4).
02 ICOL-5 binary PIC 9(4).
01 SAVE-SOLUTION.
02 SAVE-IT PIC X.
02 FILLER PIC X(4).
PROCEDURE DIVISION.
MAIN-para.
MOVE 1 TO COLUMN-1
MOVE 2 TO COLUMN-2
MOVE 3 TO ICOL-3
MOVE 4 TO ICOL-4
MOVE 5 TO ICOL-5
PERFORM SIX-SOLUTIONS
MOVE 3 TO COLUMN-2
MOVE 2 TO ICOL-3
MOVE 4 TO ICOL-4
MOVE 5 TO ICOL-5
PERFORM SIX-SOLUTIONS
MOVE 4 TO COLUMN-2
MOVE 2 TO ICOL-3
MOVE 3 TO ICOL-4
MOVE 5 TO ICOL-5
PERFORM SIX-SOLUTIONS
MOVE 5 TO COLUMN-2
MOVE 2 TO ICOL-3
MOVE 3 TO ICOL-4
MOVE 4 TO ICOL-5
PERFORM SIX-SOLUTIONS
DISPLAY SOLUTION-COUNT
STOP RUN
.
SIX-SOLUTIONS.
MOVE ICOL-3 TO COLUMN-3
MOVE ICOL-4 TO COLUMN-4
MOVE ICOL-5 TO COLUMN-5
PERFORM A-SOLUTION
MOVE ICOL-5 TO COLUMN-4
MOVE ICOL-4 TO COLUMN-5
PERFORM A-SOLUTION
MOVE ICOL-4 TO COLUMN-3
MOVE ICOL-3 TO COLUMN-4
MOVE ICOL-5 TO COLUMN-5
PERFORM A-SOLUTION
MOVE ICOL-5 TO COLUMN-4
MOVE ICOL-3 TO COLUMN-5
PERFORM A-SOLUTION
MOVE ICOL-5 TO COLUMN-3
MOVE ICOL-3 TO COLUMN-4
MOVE ICOL-4 TO COLUMN-5
PERFORM A-SOLUTION
MOVE ICOL-4 TO COLUMN-4
MOVE ICOL-3 TO COLUMN-5
PERFORM A-SOLUTION
.
A-SOLUTION.
MOVE CHAR-SET ( 1 : 1 ) TO SOLUTION ( 1 : 1 )
MOVE CHAR-SET ( COLUMN-2 : 1 ) TO SOLUTION ( 2 : 1 )
MOVE CHAR-SET ( COLUMN-3 : 1 ) TO SOLUTION ( 3 : 1 )
MOVE CHAR-SET ( COLUMN-4 : 1 ) TO SOLUTION ( 4 : 1 )
MOVE CHAR-SET ( COLUMN-5 : 1 ) TO SOLUTION ( 5 : 1 )
PERFORM SOLUTION-READY
PERFORM SOLUTIONS-FOR-REMAINING-VALUES
.
SOLUTIONS-FOR-REMAINING-VALUES.
MOVE SOLUTION TO SAVE-SOLUTION
MOVE SOLUTION ( 2 : 1 ) TO SOLUTION ( 1 : 1 )
MOVE SAVE-IT TO SOLUTION ( 2 : 1 )
PERFORM SOLUTION-READY
MOVE SAVE-SOLUTION TO SOLUTION
MOVE SOLUTION ( 3 : 1 ) TO SOLUTION ( 1 : 1 )
MOVE SAVE-IT TO SOLUTION ( 3 : 1 )
PERFORM SOLUTION-READY
MOVE SAVE-SOLUTION TO SOLUTION
MOVE SOLUTION ( 4 : 1 ) TO SOLUTION ( 1 : 1 )
MOVE SAVE-IT TO SOLUTION ( 4 : 1 )
PERFORM SOLUTION-READY
MOVE SAVE-SOLUTION TO SOLUTION
MOVE SOLUTION ( 5 : 1 ) TO SOLUTION ( 1 : 1 )
MOVE SAVE-IT TO SOLUTION ( 5 : 1 )
PERFORM SOLUTION-READY
.
SOLUTION-READY.
ADD 1 TO SOLUTION-COUNT
DISPLAY SOLUTION
.
OK. Specific program for the question. Sort of. The expected answer is probably the Ingo/Valdis Grinbergs one, to learn how to "nest" loops.
What is the program doing? Well, it is getting 1/5 of the permutations, and then relying on the symmetry in those results to generate the remaining 4/5 of the permutations with no further processing beyond rearrangement.
Why are there no loops? Because, since it is known beforehand, the answer is known beforehand. Instead of the loops, which invariably produce the same result, the result has been "hard-coded".
Can the programs be genneralised? Yes. What is the algorithm?
Well, you could describe the code, and work out how to extend it. Or you could look at the data.
The generation of six pairs of two does what? Well, the pairs of two are simply permutations of two values. The six, permutations of three values. Doing the six four times is permutations of four values.
So, to perm five values, apply each of the five individual values to the permutation pattern of four values. To perm four values, apply each of the four individual values to the permutation pattern of three values. To perm three values, apply each of the three individual values to the permutation pattern of two values. To perm two values, apply each of the two individual values to the permutation pattern of one value(!).
So, to perm N values, apply each of the N individual values to the permutation pattern of (N-1) values.
In a general solution, N = 1 requires zero iterations. N = 2 requires one iteration. N = 3 requires two iterations. N = 4 requires six iterations. N = 5 requires 24 iterations. N = N requires (N - 1)! iterations, with N = 1 a special case.
To generate all all data, rather than to hard-code initial solutions, requires the sum. N = 5, from a starting point of no available smaller permutations, requires 24 + 6 + 2 + 1 = 33 iterations.
And yes, this readily lends itself to recursion for a solution. It also lends itself to a solution with no loops at all. This is not COBOL specific, but the same for any language.
Of course, you'd never need more than one invocation per program per different N values. So again, no problem with using recursion.
The problem with recursion in COBOL, is the general unfamiliarity amongst COBOL programmers as to how to do it.
The obvious use for a "slick" version is if having to deal with N's of a "large" size (factorials are involved, so "large" arrives fairly quickly).
The other thing is "clarity". Can the next person along understand what the code is doing.
I'll do a "nice" version if I can find the time..,