Works with: COBOL version 2002
Works with: OpenCOBOL version 1.1

       01  stack.
         05  head USAGE IS POINTER VALUE NULL.

       01  node BASED.
         COPY node-info REPLACING
           01 BY 05
           node-info BY info.
         05  link USAGE IS POINTER VALUE NULL.

       01  node-info PICTURE X(10) VALUE SPACES.

       01  p PICTURE 9.
         88 nil VALUE ZERO WHEN SET TO FALSE IS 1.
         88 t   VALUE 1 WHEN SET TO FALSE IS ZERO.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. push.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       COPY p.
       COPY node.
       LINKAGE SECTION.
       COPY stack.
       01  node-info-any PICTURE X ANY LENGTH.
       PROCEDURE DIVISION USING stack node-info-any.
         ALLOCATE node
         CALL "pointerp" USING
           BY REFERENCE ADDRESS OF node
           BY REFERENCE p
         END-CALL
         IF nil
           CALL "stack-overflow-error" END-CALL
         ELSE
           MOVE node-info-any TO info OF node
           SET link OF node TO head OF stack
           SET head OF stack TO ADDRESS OF node
         END-IF
         GOBACK.
       END PROGRAM push.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. pop.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       COPY p.
       COPY node.
       LINKAGE SECTION.
       COPY stack.
       COPY node-info.
       PROCEDURE DIVISION USING stack node-info.
         CALL "empty" USING
           BY REFERENCE stack
           BY REFERENCE p
         END-CALL
         IF t
           CALL "stack-underflow-error" END-CALL
         ELSE
           SET ADDRESS OF node TO head OF stack
           SET head OF stack TO link OF node
           MOVE info OF node TO node-info
         END-IF
         FREE ADDRESS OF node
         GOBACK.
       END PROGRAM pop.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. empty.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       LINKAGE SECTION.
       COPY stack.
       COPY p.
       PROCEDURE DIVISION USING stack p.
         CALL "pointerp" USING
           BY CONTENT head OF stack
           BY REFERENCE p
         END-CALL
         IF t
           SET t TO FALSE
         ELSE
           SET t TO TRUE
         END-IF
         GOBACK.
       END PROGRAM empty.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. head.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       COPY p.
       COPY node.
       LINKAGE SECTION.
       COPY stack.
       COPY node-info.
       PROCEDURE DIVISION USING stack node-info.
         CALL "empty" USING
           BY REFERENCE stack
           BY REFERENCE p
         END-CALL
         IF t
           CALL "stack-underflow-error" END-CALL
         ELSE
           SET ADDRESS OF node TO head OF stack
           MOVE info OF node TO node-info
         END-IF
         GOBACK.
       END PROGRAM head.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. peek.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       LINKAGE SECTION.
       COPY stack.
       COPY node-info.
       PROCEDURE DIVISION USING stack node-info.
         CALL "head" USING
           BY CONTENT stack
           BY REFERENCE node-info
         END-CALL
         GOBACK.
       END PROGRAM peek.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. pointerp.
       DATA DIVISION.
       LINKAGE SECTION.
       01  test-pointer USAGE IS POINTER.
       COPY p.
       PROCEDURE DIVISION USING test-pointer p.
         IF test-pointer EQUAL NULL
           SET nil TO TRUE
         ELSE
           SET t TO TRUE
         END-IF
         GOBACK.
       END PROGRAM pointerp.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. stack-overflow-error.
       PROCEDURE DIVISION.
         DISPLAY "stack-overflow-error" END-DISPLAY
         STOP RUN.
       END PROGRAM stack-overflow-error.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. stack-underflow-error.
       PROCEDURE DIVISION.
         DISPLAY "stack-underflow-error" END-DISPLAY
         STOP RUN.
       END PROGRAM stack-underflow-error.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. copy-stack.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       COPY p.
       COPY node-info.
       LINKAGE SECTION.
       COPY stack.
       COPY stack REPLACING stack BY new-stack.
       PROCEDURE DIVISION USING stack new-stack.
         CALL "empty" USING
           BY REFERENCE stack
           BY REFERENCE p
         END-CALL
         IF nil
           CALL "pop" USING
             BY REFERENCE stack
             BY REFERENCE node-info
           END-CALL
           CALL "copy-stack" USING
             BY REFERENCE stack
             BY REFERENCE new-stack
           END-CALL
           CALL "push" USING
             BY REFERENCE stack
             BY REFERENCE node-info
           END-CALL
           CALL "push" USING
             BY REFERENCE new-stack
             BY REFERENCE node-info
           END-CALL
         END-IF
         GOBACK.
       END PROGRAM copy-stack.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. reverse-stack.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       COPY p.
       COPY node-info.
       LINKAGE SECTION.
       COPY stack.
       COPY stack REPLACING stack BY new-stack.
       PROCEDURE DIVISION USING stack new-stack.
         CALL "empty" USING
           BY REFERENCE stack
           BY REFERENCE p
         END-CALL
         IF nil
           CALL "pop" USING
             BY REFERENCE stack
             BY REFERENCE node-info
           END-CALL
           CALL "push" USING
             BY REFERENCE new-stack
             BY REFERENCE node-info
           END-CALL
           CALL "reverse-stack" USING
             BY REFERENCE stack
             BY REFERENCE new-stack
           END-CALL
           CALL "push" USING
             BY REFERENCE stack
             BY REFERENCE node-info
           END-CALL
         END-IF
         GOBACK.
       END PROGRAM reverse-stack.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. traverse-stack.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       COPY p.
       COPY node-info.
       COPY stack REPLACING stack BY new-stack.
       LINKAGE SECTION.
       COPY stack.
       PROCEDURE DIVISION USING stack.
         CALL "copy-stack" USING
           BY REFERENCE stack
           BY REFERENCE new-stack
         END-CALL
         CALL "empty" USING
           BY REFERENCE new-stack
           BY REFERENCE p
         END-CALL
         IF nil
           CALL "head" USING
             BY CONTENT new-stack
             BY REFERENCE node-info
           END-CALL
           DISPLAY node-info END-DISPLAY
           CALL "peek" USING
             BY CONTENT new-stack
             BY REFERENCE node-info
           END-CALL
           DISPLAY node-info END-DISPLAY
           CALL "pop" USING
             BY REFERENCE new-stack
             BY REFERENCE node-info
           END-CALL
           DISPLAY node-info END-DISPLAY
           CALL "traverse-stack" USING
             BY REFERENCE new-stack
           END-CALL
         END-IF
         GOBACK.
       END PROGRAM traverse-stack.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. stack-test.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       COPY stack.
       COPY stack REPLACING stack BY new-stack.
       PROCEDURE DIVISION.
         CALL "push" USING
           BY REFERENCE stack
           BY CONTENT "daleth"
         END-CALL
         CALL "push" USING
           BY REFERENCE stack
           BY CONTENT "gimel"
         END-CALL
         CALL "push" USING
           BY REFERENCE stack
           BY CONTENT "beth"
         END-CALL
         CALL "push" USING
           BY REFERENCE stack
           BY CONTENT "aleph"
         END-CALL
         CALL "traverse-stack" USING
           BY REFERENCE stack
         END-CALL
         CALL "reverse-stack" USING
           BY REFERENCE stack
           BY REFERENCE new-stack
         END-CALL
         CALL "traverse-stack" USING
           BY REFERENCE new-stack
         END-CALL
         STOP RUN.
       END PROGRAM stack-test.

       COPY stack-utilities.

implement a stack data structure with basic operations such as push, pop, and empty. The stack follows a last in, first out (LIFO) access policy and is accessed through its top. The 'push' operation stores a new element onto the stack top, 'pop' operation returns and removes the last pushed stack element, and 'empty' checks if the stack contains no elements. The 'top' operation returns the topmost element without modifying the stack. The stack implementation is used for resource management, particularly memory, and is common in programming, processors, and various algorithms.


Program-ID. Fibonacci-Sequence.
Data Division.
Working-Storage Section.
  01  FIBONACCI-PROCESSING.
    05  FIBONACCI-NUMBER  PIC 9(36)   VALUE 0.
    05  FIB-ONE           PIC 9(36)   VALUE 0.
    05  FIB-TWO           PIC 9(36)   VALUE 1.
  01  DESIRED-COUNT       PIC 9(4).
  01  FORMATTING.
    05  INTERM-RESULT     PIC Z(35)9.
    05  FORMATTED-RESULT  PIC X(36).
    05  FORMATTED-SPACE   PIC x(35).
Procedure Division.
  000-START-PROGRAM.
    Display "What place of the Fibonacci Sequence would you like (<173)? " with no advancing.
    Accept DESIRED-COUNT.
    If DESIRED-COUNT is less than 1
      Stop run.
    If DESIRED-COUNT is less than 2
      Move FIBONACCI-NUMBER to INTERM-RESULT
      Move INTERM-RESULT to FORMATTED-RESULT
      Unstring FORMATTED-RESULT delimited by all spaces into FORMATTED-SPACE,FORMATTED-RESULT
      Display FORMATTED-RESULT
      Stop run.
    Subtract 1 from DESIRED-COUNT.
    Move FIBONACCI-NUMBER to INTERM-RESULT.
    Move INTERM-RESULT to FORMATTED-RESULT.
    Unstring FORMATTED-RESULT delimited by all spaces into FORMATTED-SPACE,FORMATTED-RESULT.
    Display FORMATTED-RESULT.
    Perform 100-COMPUTE-FIBONACCI until DESIRED-COUNT = zero.
    Stop run.
  100-COMPUTE-FIBONACCI.
    Compute FIBONACCI-NUMBER = FIB-ONE + FIB-TWO.
    Move FIB-TWO to FIB-ONE.
    Move FIBONACCI-NUMBER to FIB-TWO.
    Subtract 1 from DESIRED-COUNT.
    Move FIBONACCI-NUMBER to INTERM-RESULT.
    Move INTERM-RESULT to FORMATTED-RESULT.
    Unstring FORMATTED-RESULT delimited by all spaces into FORMATTED-SPACE,FORMATTED-RESULT.
    Display FORMATTED-RESULT.
Works with: GNU Cobol version 2.0
       >>SOURCE FREE
IDENTIFICATION DIVISION.
PROGRAM-ID. fibonacci-main.

DATA DIVISION.
WORKING-STORAGE SECTION.
01  num                                 PIC 9(6) COMP.
01  fib-num                             PIC 9(6) COMP.

PROCEDURE DIVISION.
    ACCEPT num
    CALL "fibonacci" USING CONTENT num RETURNING fib-num
    DISPLAY fib-num
    .
END PROGRAM fibonacci-main.

IDENTIFICATION DIVISION.
PROGRAM-ID. fibonacci RECURSIVE.

DATA DIVISION.
LOCAL-STORAGE SECTION.
01  1-before                            PIC 9(6) COMP.
01  2-before                            PIC 9(6) COMP.

LINKAGE SECTION.
01  num                                 PIC 9(6) COMP.

01  fib-num                             PIC 9(6) COMP BASED.

PROCEDURE DIVISION USING num RETURNING fib-num.
    ALLOCATE fib-num
    EVALUATE num
        WHEN 0
            MOVE 0 TO fib-num
        WHEN 1
            MOVE 1 TO fib-num
        WHEN OTHER
            SUBTRACT 1 FROM num
            CALL "fibonacci" USING CONTENT num RETURNING 1-before
            SUBTRACT 1 FROM num
            CALL "fibonacci" USING CONTENT num RETURNING 2-before
            ADD 1-before TO 2-before GIVING fib-num
    END-EVALUATE
    .
END PROGRAM fibonacci.

generate the nth Fibonacci number, using either an iterative or recursive approach. The function also has an optional feature to support negative Fibonacci sequences.


       identification division.
       program-id. substring.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 original.
          05 value "this is a string".
       01 starting  pic 99 value 3.
       01 width     pic 99 value 8.
       01 pos       pic 99.
       01 ender     pic 99.
       01 looking   pic 99.
       01 indicator pic x.
          88 found  value high-value when set to false is low-value.
       01 look-for  pic x(8).

       procedure division.
       substring-main.

       display "Original |" original "|, n = " starting " m = " width
       display original(starting : width)
       display original(starting :)
       display original(1 : length(original) - 1)

       move "a" to look-for
       move 1 to looking
       perform find-position
       if found
           display original(pos : width)
       end-if

       move "is a st" to look-for
       move length(trim(look-for)) to looking
       perform find-position
       if found
           display original(pos : width)
       end-if
       goback.

       find-position.
       set found to false
       compute ender = length(original) - looking
       perform varying pos from 1 by 1 until pos > ender
           if original(pos : looking) equal look-for then
               set found to true
               exit perform
           end-if
       end-perform
       .

       end program substring.

- Extracts a substring starting from the nth character of a specific length m.
- Extracts a substring starting from the nth character up to the end of the string.
- Returns the entire string excluding the last character.
- Extracts a substring starting from a known character within the string of length m.
- Extracts a substring starting from a known substring within the string of length m.
- Supports any valid Unicode code point, including those in the Basic Multilingual Plane or above it.
- References logical characters (code points), not 8-bit code units for UTF-8 or 16-bit code units for UTF-16.
- Does not necessarily support all Unicode characters for other encodings like 8-bit ASCII, or EUC-JP.


Reverses a given string while preserving Unicode combining characters. For instance, it transforms "asdf" to "fdsa" and "as⃝df̅" to "f̅ds⃝a".


Works with: OpenCOBOL
       IDENTIFICATION DIVISION.
       PROGRAM-ID. Random-Nums.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  Num  PIC Z9.

       PROCEDURE DIVISION.
       Main.
           PERFORM FOREVER
               PERFORM Generate-And-Display-Num

               IF Num = 10
                   EXIT PERFORM
               ELSE
                   PERFORM Generate-And-Display-Num
               END-IF
           END-PERFORM

           GOBACK
           .

       Generate-And-Display-Num.
           COMPUTE Num =  FUNCTION REM(FUNCTION RANDOM * 100, 20)
           DISPLAY Num
           .

generate and print random numbers from 0 to 19. If the generated number is 10, the loop stops. If the number is not 10, a second random number is generated and printed before the loop restarts. If 10 is never generated, the loop runs indefinitely.


       program-id. dec25.
       data division.
       working-storage section.
       1 work-date.
        2 yr pic 9(4) value 2008.
        2 mo-da pic 9(4) value 1225. *> Dec 25
       1 wk-date redefines work-date pic 9(8).
       1 binary.
        2 int-date pic 9(8).
        2 dow pic 9(4).
       procedure division.
           perform varying yr from 2008 by 1
           until yr > 2121
               compute int-date = function integer-of-date (wk-date)
               compute dow = function mod ((int-date - 1) 7) + 1
               if dow = 7  *> Sunday = 7 per ISO 8601 and ISO 1989
                   display yr
               end-if
           end-perform
           stop run
           .
       end program dec25.

"Determines the years between 2008 and 2121 where Christmas falls on a Sunday using standard date handling libraries. The code also compares the results with other languages to identify any discrepancies due to issues like overflow in date/time representation."


Works with: Visual COBOL
       IDENTIFICATION DIVISION.
       PROGRAM-ID. quicksort RECURSIVE.

       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       01  temp                   PIC S9(8).

       01  pivot                  PIC S9(8).

       01  left-most-idx          PIC 9(5).
       01  right-most-idx         PIC 9(5).

       01  left-idx               PIC 9(5).
       01  right-idx              PIC 9(5).

       LINKAGE SECTION.
       78  Arr-Length             VALUE 50.

       01  arr-area.
           03  arr                PIC S9(8) OCCURS Arr-Length TIMES.

       01  left-val               PIC 9(5).
       01  right-val              PIC 9(5).

       PROCEDURE DIVISION USING REFERENCE arr-area, OPTIONAL left-val,
               OPTIONAL right-val.
           IF left-val IS OMITTED OR right-val IS OMITTED
               MOVE 1 TO left-most-idx, left-idx
               MOVE Arr-Length TO right-most-idx, right-idx
           ELSE
               MOVE left-val TO left-most-idx, left-idx
               MOVE right-val TO right-most-idx, right-idx
           END-IF

           IF right-most-idx - left-most-idx < 1
               GOBACK
           END-IF

           COMPUTE pivot = arr ((left-most-idx + right-most-idx) / 2)

           PERFORM UNTIL left-idx > right-idx
               PERFORM VARYING left-idx FROM left-idx BY 1
                   UNTIL arr (left-idx) >= pivot
               END-PERFORM

               PERFORM VARYING right-idx FROM right-idx BY -1
                   UNTIL arr (right-idx) <= pivot
               END-PERFORM

               IF left-idx <= right-idx
                   MOVE arr (left-idx) TO temp
                   MOVE arr (right-idx) TO arr (left-idx)
                   MOVE temp TO arr (right-idx)

                   ADD 1 TO left-idx
                   SUBTRACT 1 FROM right-idx
               END-IF
           END-PERFORM

           CALL "quicksort" USING REFERENCE arr-area,
               CONTENT left-most-idx, right-idx
           CALL "quicksort" USING REFERENCE arr-area, CONTENT left-idx,
               right-most-idx

           GOBACK
           .

implement the Quicksort algorithm to sort an array or list of elements. The algorithm works by choosing a pivot element and dividing the rest of the elements into two partitions - one with elements less than the pivot and the other with elements greater than the pivot. It then recursively sorts these partitions and joins them with the pivot to get the sorted array. The codes also include an optimized version of Quicksort that works in place by swapping elements within the array to avoid memory allocation of more arrays. The pivot selection method is not specified.


Works with: OpenCOBOL
       IDENTIFICATION DIVISION.
       PROGRAM-ID. Date-Format.

       DATA DIVISION.
       WORKING-STORAGE SECTION.

       01  Days-Area.
           03  Days-Data.
               05  FILLER PIC X(9) VALUE "Monday".
               05  FILLER PIC X(9) VALUE "Tuesday".
               05  FILLER PIC X(9) VALUE "Wednesday".
               05  FILLER PIC X(9) VALUE "Thursday".
               05  FILLER PIC X(9) VALUE "Friday".
               05  FILLER PIC X(9) VALUE "Saturday".
               05  FILLER PIC X(9) VALUE "Sunday".

           03  Days-Values REDEFINES Days-Data.
               05  Days-Table PIC X(9) OCCURS 7 TIMES.

       01  Months-Area.
           03  Months-Data.
               05  FILLER PIC X(9) VALUE "January".
               05  FILLER PIC X(9) VALUE "February".
               05  FILLER PIC X(9) VALUE "March".
               05  FILLER PIC X(9) VALUE "April".
               05  FILLER PIC X(9) VALUE "May".
               05  FILLER PIC X(9) VALUE "June".
               05  FILLER PIC X(9) VALUE "July".
               05  FILLER PIC X(9) VALUE "August".
               05  FILLER PIC X(9) VALUE "September".
               05  FILLER PIC X(9) VALUE "October".
               05  FILLER PIC X(9) VALUE "November".
               05  FILLER PIC X(9) VALUE "December".

           03  Months-Values REDEFINES Months-Data.
               05  Months-Table PIC X(9) OCCURS 12 TIMES.

       01  Current-Date-Str.
           03  Current-Year     PIC X(4).
           03  Current-Month    PIC X(2).
           03  Current-Day      PIC X(2).

       01  Current-Day-Of-Week  PIC 9.

       PROCEDURE DIVISION.
           MOVE FUNCTION CURRENT-DATE (1:8) TO Current-Date-Str

           DISPLAY Current-Year "-" Current-Month "-" Current-Day

           ACCEPT Current-Day-Of-Week FROM DAY-OF-WEEK
           DISPLAY
               FUNCTION TRIM(
                   Days-Table (FUNCTION NUMVAL(Current-Day-Of-Week)))
               ", "
               FUNCTION TRIM(
                   Months-Table (FUNCTION NUMVAL(Current-Month)))
               " "
               Current-Day
               ", "
               Current-Year
           END-DISPLAY

           GOBACK
           .

display the current date in two formats: "2007-11-23" and "Friday, November 23, 2007".


IDENTIFICATION DIVISION.
PROGRAM-ID. TOROMAN.
DATA DIVISION.
working-storage section.
  01 ws-number pic 9(4) value 0.
  01 ws-save-number pic 9(4).
  01 ws-tbl-def.
    03 filler pic x(7) value '1000M  '.
    03 filler pic x(7) value '0900CM '.
    03 filler pic x(7) value '0500D  '.
    03 filler pic x(7) value '0400CD '.
    03 filler pic x(7) value '0100C  '.
    03 filler pic x(7) value '0090XC '.
    03 filler pic x(7) value '0050L  '.
    03 filler pic x(7) value '0040XL '.
    03 filler pic x(7) value '0010X  '.
    03 filler pic x(7) value '0009IX '.
    03 filler pic x(7) value '0005V  '.
    03 filler pic x(7) value '0004IV '.
    03 filler pic x(7) value '0001I  '.
  01  filler redefines ws-tbl-def.
    03 filler occurs 13 times indexed by rx.
      05 ws-tbl-divisor    pic 9(4).
      05 ws-tbl-roman-ch   pic x(1) occurs 3 times indexed by cx.
  01 ocx pic 99.
  01 ws-roman.
    03 ws-roman-ch         pic x(1) occurs 16 times.
PROCEDURE DIVISION.
  accept ws-number
  perform
  until ws-number = 0
    move ws-number to ws-save-number
    if ws-number > 0 and ws-number < 4000
      initialize ws-roman
      move 0 to ocx
      perform varying rx from 1 by +1
      until ws-number = 0
        perform until ws-number < ws-tbl-divisor (rx)
          perform varying cx from 1 by +1
  		  until ws-tbl-roman-ch (rx, cx) = spaces
            compute ocx = ocx + 1
            move ws-tbl-roman-ch (rx, cx) to ws-roman-ch (ocx)
          end-perform
          compute ws-number = ws-number - ws-tbl-divisor (rx)
        end-perform
      end-perform
      display 'inp=' ws-save-number ' roman=' ws-roman
    else
      display 'inp=' ws-save-number ' invalid'
    end-if
    accept ws-number
  end-perform
  .

create a function that converts a positive integer into its equivalent Roman numeral representation.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. arrays.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  fixed-length-table.
           03  fixed-table-elt      PIC X OCCURS 5 TIMES.

       01  table-length             PIC 9(5) VALUE 1.
       01  variable-length-table.
           03  variable-table-elt   PIC X OCCURS 1 TO 5 TIMES
               DEPENDING ON table-length.

       01  initial-value-area.
           03  initial-values.
               05  FILLER           PIC X(10) VALUE "One".
               05  FILLER           PIC X(10) VALUE "Two".
               05  FILLER           PIC X(10) VALUE "Three".
           03 initial-value-table REDEFINES initial-values.
              05  initial-table-elt PIC X(10) OCCURS 3 TIMES.

       01  indexed-table.
           03  indexed-elt          PIC X OCCURS 5 TIMES
               INDEXED BY table-index.

       PROCEDURE DIVISION.
           *> Assigning the contents of an entire table.
           MOVE "12345" TO fixed-length-table

           *>  Indexing an array (using an index)
           MOVE 1 TO table-index
           MOVE "1" TO indexed-elt (table-index)

           *> Pushing a value into a variable-length table.
           ADD 1 TO table-length
           MOVE "1" TO variable-table-elt (2)

           GOBACK
           .

demonstrate the basic syntax of arrays in a specific programming language. It includes the creation of both fixed-length and dynamic arrays, assigning values to them, and retrieving an element from them. The codes also handle the concept of arrays in COBOL, where they are referred to as tables and their indexes start from 1.


Works with: COBOL 85 standard

     $set ans85 flag"ans85" flagas"s" sequential"line"

       identification division.
       program-id. copyfile.
       environment division.
       input-output section.
       file-control.
           select input-file assign to "input.txt"
               organization sequential
           .
           select output-file assign to "output.txt"
               organization sequential
           .
       data division.
       file section.
       fd input-file.
       1 input-record pic x(80).
       fd output-file.
       1 output-record pic x(80).
       working-storage section.
       1 end-of-file-flag pic 9 value 0.
         88 eof value 1.
       1 text-line pic x(80).
       procedure division.
       begin.
           open input input-file
               output output-file
           perform read-input
           perform until eof
               write output-record from text-line
               perform read-input
           end-perform
           close input-file output-file
           stop run
           .
       read-input.
           read input-file into text-line
           at end
               set eof to true
           end-read
           .
       end program copyfile.

Works with: OpenCOBOL
       IDENTIFICATION DIVISION.
       PROGRAM-ID. file-io.

       ENVIRONMENT DIVISION.
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
           SELECT in-file ASSIGN "input.txt"
               ORGANIZATION LINE SEQUENTIAL.

           SELECT OPTIONAL out-file ASSIGN "output.txt"
               ORGANIZATION LINE SEQUENTIAL.

       DATA DIVISION.
       FILE SECTION.
       FD  in-file.
       01  in-line                 PIC X(256).

       FD  out-file.
       01  out-line                PIC X(256).

       PROCEDURE DIVISION.
       DECLARATIVES.
       in-file-error SECTION.
           USE AFTER ERROR ON in-file.
           DISPLAY "An error occurred while using input.txt."
           GOBACK
           .
       out-file-error SECTION.
           USE AFTER ERROR ON out-file.
           DISPLAY "An error occurred while using output.txt."
           GOBACK
           .
       END DECLARATIVES.

       mainline.
           OPEN INPUT in-file
           OPEN OUTPUT out-file

           PERFORM FOREVER
               READ in-file
                   AT END
                       EXIT PERFORM
               END-READ
               WRITE out-line FROM in-line
           END-PERFORM

           CLOSE in-file, out-file
           .

Works with: OpenCOBOL
Works with: Visual COBOL
*> Originally from ACUCOBOL-GT
CALL "C$COPY" USING "input.txt", "output.txt", 0

*> Originally from Micro Focus COBOL
CALL "CBL_COPY_FILE" USING "input.txt", "output.txt"

demonstrate reading the contents of "input.txt" into a variable, and then writing these contents into a newly created file "output.txt" using Micro Focus COBOL. The process does not utilize direct copy commands but involves an intermediate variable.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. string-case-85.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  example PIC X(9) VALUE "alphaBETA".

       01  result  PIC X(9).

       PROCEDURE DIVISION.
           DISPLAY "Example: " example

           *> Using the intrinsic functions.
           DISPLAY "Lower-case: " FUNCTION LOWER-CASE(example)

           DISPLAY "Upper-case: " FUNCTION UPPER-CASE(example)

           *> Using INSPECT
           MOVE example TO result
           INSPECT result CONVERTING "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
               TO "abcdefghijklmnopqrstuvwxyz"
           DISPLAY "Lower-case: " result

           MOVE example TO result
           INSPECT result CONVERTING "abcdefghijklmnopqrstuvwxyz"
               TO  "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
           DISPLAY "Upper-case: " result

           GOBACK
           .

       IDENTIFICATION DIVISION.
       PROGRAM-ID. string-case-extensions.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       78  example VALUE "alphaBETA".

       01  result  PIC X(9).

       PROCEDURE DIVISION.
           DISPLAY "Example: " example

           *> ACUCOBOL-GT
           MOVE example TO result
           CALL "C$TOLOWER" USING result, BY VALUE 9
           DISPLAY "Lower-case: " result

           MOVE example TO result
           CALL "C$TOUPPER" USING result, BY VALUE 9
           DISPLAY "Upper-case: " result

           *> Visual COBOL
           MOVE example TO result
           CALL "CBL_TOLOWER" USING result, BY VALUE 9
           DISPLAY "Lower-case: " result

           MOVE example TO result
           CALL "CBL_TOUPPER" USING result BY VALUE 9
           DISPLAY "Upper-case: " result

           GOBACK
           .

demonstrate the conversion of the string "alphaBETA" to upper-case and lower-case using the default string literal or ASCII encoding. The code also showcases additional case conversion functions such as swapping case or capitalizing the first letter if available in the language's library. Note that in some languages, the toLower and toUpper functions may not be reversible.


Works with: GnuCOBOL
       identification division.
       program-id. collections.

       data division.
       working-storage section.
       01 sample-table.
          05 sample-record occurs 1 to 3 times depending on the-index.
             10 sample-alpha   pic x(4).
             10 filler         pic x value ":".
             10 sample-number  pic 9(4).
             10 filler         pic x value space.
       77 the-index            usage index.

       procedure division.
       collections-main.

       set the-index to 3
       move 1234 to sample-number(1)
       move "abcd" to sample-alpha(1)

       move "test" to sample-alpha(2)

       move 6789 to sample-number(3)
       move "wxyz" to sample-alpha(3)

       display "sample-table    : " sample-table
       display "sample-number(1): " sample-number(1)
       display "sample-record(2): " sample-record(2)
       display "sample-number(3): " sample-number(3)

      *> abend: out of bounds subscript, -debug turns on bounds check
       set the-index down by 1
       display "sample-table    : " sample-table
       display "sample-number(3): " sample-number(3)

       goback.
       end program collections.

The code creates a collection in a statically-typed language and adds a few values to it. It demonstrates the usage of collections, arrays, and various types of linked lists. It also includes an example of a small record layout within a table in COBOL, showing how to handle fixed length records and tables in this environment. The code also demonstrates a run-time bounds check.


Works with: OpenCOBOL
       IDENTIFICATION DIVISION.
       PROGRAM-ID. Loop-N-And-Half.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  I    PIC 99.
       01  List PIC X(45).

       PROCEDURE DIVISION.
           PERFORM FOREVER
               *> The list to display must be built up because using
               *> DISPLAY adds an endline at the end automatically.
               STRING FUNCTION TRIM(List) " "  I  INTO List

               IF I = 10
                   EXIT PERFORM
               END-IF

               STRING FUNCTION TRIM(List) "," INTO List

               ADD 1 TO I
           END-PERFORM

           DISPLAY List

           GOBACK
           .

IDENTIFICATION DIVISION.
PROGRAM-ID. LOOP-1p5-NOADV.
DATA DIVISION.
WORKING-STORAGE SECTION.
01  I    PIC 99 VALUE 1.
01	IDISP	PIC Z9.
PROCEDURE DIVISION.
	PERFORM FOREVER
		MOVE I TO IDISP
		DISPLAY FUNCTION TRIM(IDISP) WITH NO ADVANCING
		IF I = 10
			EXIT PERFORM
		END-IF
		DISPLAY ", " WITH NO ADVANCING
		ADD 1 TO I
	END-PERFORM.
	STOP RUN.
	END-PROGRAM.

IDENTIFICATION DIVISION.
PROGRAM-ID. LOOP-1p5-NOADV-GOTO.
DATA DIVISION.
WORKING-STORAGE SECTION.
01  I	PIC 99	VALUE 1.
	88	END-LIST	VALUE 10.
01	I-OUT	PIC Z9.
PROCEDURE DIVISION.
01-LOOP.
	MOVE I TO I-OUT.
	DISPLAY FUNCTION TRIM(I-OUT) WITH NO ADVANCING.
	IF END-LIST GO TO 02-DONE.
	DISPLAY ", " WITH NO ADVANCING.
	ADD 1 TO I.
	GO TO 01-LOOP.
02-DONE.
	STOP RUN.
	END-PROGRAM.

IDENTIFICATION DIVISION.
PROGRAM-ID. LOOP-1p5-NOADV-VARY.
DATA DIVISION.
WORKING-STORAGE SECTION.
01  I    	PIC 99  VALUE 1.
	88	END-LIST	VALUE 10.
01	I-OUT	PIC Z9.
PROCEDURE DIVISION.
	PERFORM WITH TEST AFTER VARYING I FROM 1 BY 1 UNTIL END-LIST
		MOVE I TO I-OUT
		DISPLAY FUNCTION TRIM(I-OUT) WITH NO ADVANCING
		IF NOT END-LIST
			DISPLAY ", " WITH NO ADVANCING
		END-IF
	END-PERFORM.
	STOP RUN.
	END-PROGRAM.

demonstrate a loop that prints a comma-separated list of numbers from 1 to 10, using separate output statements for the number and the comma within the loop body. The loop implementation uses 'DISPLAY NO ADVANCING', 'GO TO', 88-level, and 'PERFORM VARYING' in the procedure division.


IDENTIFICATION DIVISION.
       PROGRAM-ID.  CALEND.
       ENVIRONMENT DIVISION.
       INPUT-OUTPUT SECTION.
       DATA DIVISION.

       WORKING-STORAGE SECTION.
       01  WS-DAY-NAMES-DEF.
         03 FILLER PIC X(09) VALUE 'SUNDAY   '.
         03 FILLER PIC X(09) VALUE 'MONDAY   '.
         03 FILLER PIC X(09) VALUE 'TUESDAY  '.
         03 FILLER PIC X(09) VALUE 'WEDNESDAY'.
         03 FILLER PIC X(09) VALUE 'THURSDAY '.
         03 FILLER PIC X(09) VALUE 'FRIDAY   '.
         03 FILLER PIC X(09) VALUE 'SATURDAY '.
       01  FILLER REDEFINES WS-DAY-NAMES-DEF.
         03  WS-DAY-NAME       PIC X(09) OCCURS 07 TIMES.

       01  WS-MTH-INFO-DEF.
         03 FILLER PIC X(11) VALUE 'JANUARY  31'.
         03 FILLER PIC X(11) VALUE 'FEBRUARY 28'.
         03 FILLER PIC X(11) VALUE 'MARCH    31'.
         03 FILLER PIC X(11) VALUE 'APRIL    30'.
         03 FILLER PIC X(11) VALUE 'MAY      31'.
         03 FILLER PIC X(11) VALUE 'JUNE     30'.
         03 FILLER PIC X(11) VALUE 'JULY     31'.
         03 FILLER PIC X(11) VALUE 'AUGUST   31'.
         03 FILLER PIC X(11) VALUE 'SEPTEMBER30'.
         03 FILLER PIC X(11) VALUE 'OCTOBER  31'.
         03 FILLER PIC X(11) VALUE 'NOVEMBER 30'.
         03 FILLER PIC X(11) VALUE 'DECEMBER 31'.
       01  FILLER REDEFINES WS-MTH-INFO-DEF.
         03  WS-MTH-INFO-TABLE OCCURS 12 TIMES.
           05  WS-MTH-INFO-NAME   PIC X(09).
           05  WS-MTH-INFO-DAYS   PIC 9(02).

       01  WS-MTH-AREA.
         03  WS-MTH-DD         PIC S99.
         03  WS-DAY1           PIC   9.
         03  WS-DAYS           PIC  99.
         03  WS-DD             PIC   9.
         03  WS-WK             PIC   9.
         03  WS-MM             PIC  99.
         03  WS-QQ             PIC  99.

         03  WS-MTH-MONTH  OCCURS 12 TIMES.
           05  WS-MTH-WEEK OCCURS 6 TIMES.
             07  WS-DAY-FLD      OCCURS 7 TIMES.
               09  WS-DAY        PIC ZZ.
       01  INPDATE-RECORD.
           05  INPD-YEAR          PIC 9(04).
           05  FILLER             PIC X(01).
           05  INPD-MONTH         PIC 9(02).
           05  FILLER             PIC X(01).
           05  INPD-DAY           PIC 9(02).
       01  WMS-DOW                PIC 9(01).
       01  WS-PRT                 PIC X(132).
       01  WS-COL                 PIC  9(03) VALUE 0.
       01  WS-PP                  PIC  9(03) VALUE 0.
       01  WS-CFGN.
         03  FILLER               PIC  9(03) VALUE  80.
         03  FILLER               PIC  9(02) VALUE  5.
         03  FILLER               PIC  9(01) VALUE  1.
         03  FILLER               PIC  9(02) VALUE  5.
         03  FILLER               PIC  9(01) VALUE  2.
       01  WS-CFGW.
         03  FILLER               PIC  9(03) VALUE 120.
         03  FILLER               PIC  9(02) VALUE 10.
         03  FILLER               PIC  9(01) VALUE  2.
         03  FILLER               PIC  9(02) VALUE 10.
         03  FILLER               PIC  9(01) VALUE  3.
       01  WS-CFG.
         03  WS-LS                PIC  9(03) VALUE 120.
         03  WS-LMAR              PIC  9(02) VALUE 10.
         03  WS-SPBD              PIC  9(01) VALUE  2.
         03  WS-SPBC              PIC  9(02) VALUE 10.
         03  WS-DNMW              PIC  9(01) VALUE  3.
       PROCEDURE DIVISION.
           MOVE '1969-01-01' TO INPDATE-RECORD
           MOVE WS-CFGN   TO WS-CFG
           IF  (FUNCTION MOD ( INPD-YEAR , 400 ) = 0
           OR  (FUNCTION MOD ( INPD-YEAR , 4   ) = 0
               AND
               FUNCTION MOD ( INPD-YEAR , 100 ) NOT = 0))
             MOVE 29         TO WS-MTH-INFO-DAYS (02)
           ELSE
             MOVE 28         TO WS-MTH-INFO-DAYS (02)
           END-IF

           PERFORM VARYING WS-MM FROM 1 BY +1
           UNTIL WS-MM > 12
           MOVE WS-MM TO INPD-MONTH
           CALL 'DATE2DOW' USING INPDATE-RECORD, WMS-DOW
           COMPUTE WS-MTH-DD = 1 - WMS-DOW
           COMPUTE WS-DAYS = WS-MTH-INFO-DAYS (INPD-MONTH)
           PERFORM VARYING WS-WK FROM 1 BY +1
           UNTIL WS-WK > 6
             PERFORM VARYING WS-DD FROM 1 BY +1
             UNTIL WS-DD > 7
               COMPUTE WS-MTH-DD = WS-MTH-DD + 1
               IF (WS-MTH-DD < 1)
               OR (WS-MTH-DD > WS-DAYS)
                 MOVE 0         TO WS-DAY (WS-MM, WS-WK, WS-DD)
               ELSE
                 MOVE WS-MTH-DD TO WS-DAY (WS-MM, WS-WK, WS-DD)
               END-IF
             END-PERFORM
           END-PERFORM
           END-PERFORM

           COMPUTE WS-MM = 0
           PERFORM VARYING WS-QQ FROM 1 BY +1
           UNTIL WS-QQ > 4

             INITIALIZE WS-PRT
             COMPUTE WS-PP = 1
             PERFORM VARYING WS-COL FROM 1 BY +1
             UNTIL WS-COL > 3
             COMPUTE WS-MM = 3 * (WS-QQ - 1) + WS-COL

               IF WS-COL = 1
                 COMPUTE WS-PP = WS-PP + WS-LMAR + 2 - WS-DNMW
               ELSE
                 COMPUTE WS-PP = WS-PP + WS-SPBC + 2 - WS-DNMW
               END-IF
               MOVE WS-MTH-INFO-NAME (WS-MM)
                             TO WS-PRT(WS-PP:9)
               COMPUTE WS-PP
               =       WS-PP + ( 2 * 7 + WS-SPBD * 6 + WS-SPBD - 1)
               -       4
               MOVE INPD-YEAR TO WS-PRT (WS-PP:4)
               COMPUTE WS-PP = WS-PP + 4
             END-PERFORM
             DISPLAY WS-PRT (1:WS-LS)

             INITIALIZE WS-PRT
             COMPUTE WS-PP = 1
             PERFORM VARYING WS-COL FROM 1 BY +1
             UNTIL WS-COL > 3
             COMPUTE WS-MM = 3 * (WS-QQ - 1) + WS-COL

               IF WS-COL = 1
                 COMPUTE WS-PP = WS-PP + WS-LMAR + 2 - WS-DNMW
               ELSE
                 COMPUTE WS-PP = WS-PP + WS-SPBC + 2 - WS-DNMW
               END-IF
               PERFORM VARYING WS-DD FROM 1 BY +1
               UNTIL WS-DD > 7
                 IF WS-DD > 1
                   COMPUTE WS-PP = WS-PP + WS-SPBD + 2 - WS-DNMW
                 END-IF
                 MOVE WS-DAY-NAME (WS-DD) (1:WS-DNMW)
                             TO WS-PRT (WS-PP:WS-DNMW)
                 COMPUTE WS-PP = WS-PP + WS-DNMW
               END-PERFORM
             END-PERFORM
             DISPLAY WS-PRT (1:WS-LS)

             PERFORM VARYING WS-WK FROM 1 BY +1
             UNTIL WS-WK > 6
               INITIALIZE WS-PRT
               COMPUTE WS-PP = 1
               PERFORM VARYING WS-COL FROM 1 BY +1
               UNTIL WS-COL > 3
               COMPUTE WS-MM = 3 * (WS-QQ - 1) + WS-COL

                 IF WS-COL = 1
                   COMPUTE WS-PP = WS-PP + WS-LMAR
                 ELSE
                   COMPUTE WS-PP = WS-PP + WS-SPBC
                 END-IF
                 PERFORM VARYING WS-DD FROM 1 BY +1
                 UNTIL WS-DD > 7
                   IF WS-DD > 1
                     COMPUTE WS-PP = WS-PP + WS-SPBD
                   END-IF
                   MOVE WS-DAY (WS-MM, WS-WK, WS-DD)
                               TO WS-PRT (WS-PP:2)
                   COMPUTE WS-PP = WS-PP + 2
                 END-PERFORM
               END-PERFORM
               DISPLAY WS-PRT (1:WS-LS)
             END-PERFORM
             DISPLAY ' '
           END-PERFORM
           GOBACK
           .
       END PROGRAM CALEND.
       IDENTIFICATION DIVISION.
       PROGRAM-ID.  DATE2DOW.
       ENVIRONMENT DIVISION.
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  WMS-WORK-AREA.
         03  WMS-YEAR       PIC 9(04).
         03  WMS-MONTH      PIC 9(02).
         03  WMS-CSYS       PIC 9(01) VALUE 1.
         03  WMS-SUM        pic 9(04).
       LINKAGE SECTION.
       01  INPDATE-RECORD.
           05  INPD-YEAR          PIC 9(04).
           05  FILLER             PIC X(01).
           05  INPD-MONTH         PIC 9(02).
           05  FILLER             PIC X(01).
           05  INPD-DAY           PIC 9(02).
       01  WMS-DOW                PIC 9(01).
       PROCEDURE DIVISION USING INPDATE-RECORD, WMS-DOW.
       1010-CONVERT-DATE-TO-DOW.
           IF INPD-MONTH < 3
               COMPUTE WMS-MONTH = INPD-MONTH + 12
               COMPUTE WMS-YEAR  = INPD-YEAR - 1
           ELSE
               COMPUTE WMS-MONTH = INPD-MONTH
               COMPUTE WMS-YEAR  = INPD-YEAR
           END-IF
           COMPUTE WMS-SUM  =
                            ( INPD-DAY + 2 * WMS-MONTH + WMS-YEAR
                            + FUNCTION INTEGER (6 * (WMS-MONTH + 1) / 10)
                            + FUNCTION INTEGER ( WMS-YEAR / 4   )
                            - FUNCTION INTEGER ( WMS-YEAR / 100 )
                            + FUNCTION INTEGER ( WMS-YEAR / 400 )
                            + WMS-CSYS )
           COMPUTE WMS-DOW = FUNCTION MOD (WMS-SUM, 7) + 1
           GOBACK
           .
       END PROGRAM DATE2DOW.

provide an algorithm to format a calendar that fills a page 132 characters wide, with all code written in uppercase. This is inspired by 1969 era line printers and the concept that "real programmers think in UPPERCASE". The code does not include Snoopy generation but instead outputs a placeholder. The code and output follow the example of a "REAL programmer" calendar.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. Letter-Frequency.
       AUTHOR.  Bill Gunshannon.
       INSTALLATION.  Home.
       DATE-WRITTEN.  12 December 2021.
      ************************************************************
      ** Program Abstract:
      **   A rather simplistic program to do the kind of thing
      **   that COBOL does really well.
      ************************************************************

       ENVIRONMENT DIVISION.

       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
            SELECT Text-File ASSIGN TO "File.txt"
                 ORGANIZATION IS LINE SEQUENTIAL.

       DATA DIVISION.

       FILE SECTION.

       FD  Text-File
           DATA RECORD IS Record-Name.
       01  Record-Name           PIC X(80).

       WORKING-STORAGE SECTION.

       01 Eof                   PIC X     VALUE 'F'.

       01  Letter-cnt.
           05  A-cnt            PIC 9(5)    VALUE 0.
           05  B-cnt            PIC 9(5)    VALUE 0.
           05  C-cnt            PIC 9(5)    VALUE 0.
           05  D-cnt            PIC 9(5)    VALUE 0.
           05  E-cnt            PIC 9(5)    VALUE 0.
           05  F-cnt            PIC 9(5)    VALUE 0.
           05  G-cnt            PIC 9(5)    VALUE 0.
           05  H-cnt            PIC 9(5)    VALUE 0.
           05  I-cnt            PIC 9(5)    VALUE 0.
           05  J-cnt            PIC 9(5)    VALUE 0.
           05  K-cnt            PIC 9(5)    VALUE 0.
           05  L-cnt            PIC 9(5)    VALUE 0.
           05  M-cnt            PIC 9(5)    VALUE 0.
           05  N-cnt            PIC 9(5)    VALUE 0.
           05  O-cnt            PIC 9(5)    VALUE 0.
           05  P-cnt            PIC 9(5)    VALUE 0.
           05  Q-cnt            PIC 9(5)    VALUE 0.
           05  R-cnt            PIC 9(5)    VALUE 0.
           05  S-cnt            PIC 9(5)    VALUE 0.
           05  T-cnt            PIC 9(5)    VALUE 0.
           05  U-cnt            PIC 9(5)    VALUE 0.
           05  V-cnt            PIC 9(5)    VALUE 0.
           05  W-cnt            PIC 9(5)    VALUE 0.
           05  X-cnt            PIC 9(5)    VALUE 0.
           05  Y-cnt            PIC 9(5)    VALUE 0.
           05  Z-cnt            PIC 9(5)    VALUE 0.

       01  Letter-disp.
           05  A-cnt            PIC ZZZZ9.
           05  B-cnt            PIC ZZZZ9.
           05  C-cnt            PIC ZZZZ9.
           05  D-cnt            PIC ZZZZ9.
           05  E-cnt            PIC ZZZZ9.
           05  F-cnt            PIC ZZZZ9.
           05  G-cnt            PIC ZZZZ9.
           05  H-cnt            PIC ZZZZ9.
           05  I-cnt            PIC ZZZZ9.
           05  J-cnt            PIC ZZZZ9.
           05  K-cnt            PIC ZZZZ9.
           05  L-cnt            PIC ZZZZ9.
           05  M-cnt            PIC ZZZZ9.
           05  N-cnt            PIC ZZZZ9.
           05  O-cnt            PIC ZZZZ9.
           05  P-cnt            PIC ZZZZ9.
           05  Q-cnt            PIC ZZZZ9.
           05  R-cnt            PIC ZZZZ9.
           05  S-cnt            PIC ZZZZ9.
           05  T-cnt            PIC ZZZZ9.
           05  U-cnt            PIC ZZZZ9.
           05  V-cnt            PIC ZZZZ9.
           05  W-cnt            PIC ZZZZ9.
           05  X-cnt            PIC ZZZZ9.
           05  Y-cnt            PIC ZZZZ9.
           05  Z-cnt            PIC ZZZZ9.

       PROCEDURE DIVISION.

       Main-Program.
           OPEN INPUT  Text-File
           PERFORM UNTIL Eof = 'T'
              READ  Text-File
                    AT END MOVE 'T' to Eof
              END-READ
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING A-cnt OF Letter-cnt  FOR ALL 'A'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING B-cnt OF Letter-cnt  FOR ALL 'B'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING C-cnt OF Letter-cnt  FOR ALL 'C'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING D-cnt OF Letter-cnt  FOR ALL 'D'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING E-cnt OF Letter-cnt  FOR ALL 'E'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING F-cnt OF Letter-cnt  FOR ALL 'F'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING G-cnt OF Letter-cnt  FOR ALL 'G'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING H-cnt OF Letter-cnt  FOR ALL 'H'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING I-cnt OF Letter-cnt  FOR ALL 'I'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING J-cnt OF Letter-cnt  FOR ALL 'J'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING K-cnt OF Letter-cnt  FOR ALL 'K'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING L-cnt OF Letter-cnt  FOR ALL 'L'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING M-cnt OF Letter-cnt  FOR ALL 'M'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING N-cnt OF Letter-cnt  FOR ALL 'N'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING O-cnt OF Letter-cnt  FOR ALL 'O'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING P-cnt OF Letter-cnt  FOR ALL 'P'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING Q-cnt OF Letter-cnt  FOR ALL 'Q'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING R-cnt OF Letter-cnt  FOR ALL 'R'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING S-cnt OF Letter-cnt  FOR ALL 'S'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING T-cnt OF Letter-cnt  FOR ALL 'T'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING U-cnt OF Letter-cnt  FOR ALL 'U'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING V-cnt OF Letter-cnt  FOR ALL 'V'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING W-cnt OF Letter-cnt  FOR ALL 'W'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING X-cnt OF Letter-cnt  FOR ALL 'X'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING Y-cnt OF Letter-cnt  FOR ALL 'Y'
           INSPECT FUNCTION UPPER-CASE(Record-Name)
                   TALLYING Z-cnt OF Letter-cnt  FOR ALL 'Z'
           END-PERFORM.
           CLOSE Text-File.
           MOVE CORRESPONDING Letter-cnt To Letter-disp.
           DISPLAY 'Letter Frequency Distribution'.
           DISPLAY '-----------------------------'.
           DISPLAY 'A : ' A-cnt OF Letter-disp '          '
                   'N : ' N-cnt OF Letter-disp.
           DISPLAY 'B : ' B-cnt OF Letter-disp '          '
                   'O : ' O-cnt OF Letter-disp.
           DISPLAY 'C : ' C-cnt OF Letter-disp '          '
                   'P : ' P-cnt OF Letter-disp.
           DISPLAY 'D : ' D-cnt OF Letter-disp '          '
                   'Q : ' Q-cnt OF Letter-disp.
           DISPLAY 'E : ' E-cnt OF Letter-disp '          '
                   'R : ' R-cnt OF Letter-disp.
           DISPLAY 'F : ' F-cnt OF Letter-disp '          '
                   'S : ' S-cnt OF Letter-disp.
           DISPLAY 'G : ' G-cnt OF Letter-disp '          '
                   'T : ' T-cnt OF Letter-disp.
           DISPLAY 'H : ' H-cnt OF Letter-disp '          '
                   'U : ' U-cnt OF Letter-disp.
           DISPLAY 'I : ' I-cnt OF Letter-disp '          '
                   'V : ' V-cnt OF Letter-disp.
           DISPLAY 'J : ' J-cnt OF Letter-disp '          '
                   'W : ' W-cnt OF Letter-disp.
           DISPLAY 'K : ' K-cnt OF Letter-disp '          '
                   'X : ' X-cnt OF Letter-disp.
           DISPLAY 'L : ' L-cnt OF Letter-disp '          '
                   'Y : ' Y-cnt OF Letter-disp.
           DISPLAY 'M : ' M-cnt OF Letter-disp '          '
                   'Z : ' Z-cnt OF Letter-disp.
           STOP RUN.

       END-PROGRAM.

Open a text file, count the frequency of each letter, and differentiate between counting all characters or only letters A to Z.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. FACTORS.
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  CALCULATING.
           03  NUM  USAGE BINARY-LONG VALUE ZERO.
           03  LIM  USAGE BINARY-LONG VALUE ZERO.
           03  CNT  USAGE BINARY-LONG VALUE ZERO.
           03  DIV  USAGE BINARY-LONG VALUE ZERO.
           03  REM  USAGE BINARY-LONG VALUE ZERO.
           03  ZRS  USAGE BINARY-SHORT VALUE ZERO.

       01  DISPLAYING.
           03  DIS  PIC 9(10) USAGE DISPLAY.

       PROCEDURE DIVISION.
       MAIN-PROCEDURE.
           DISPLAY "Factors of? " WITH NO ADVANCING
           ACCEPT NUM
           DIVIDE NUM BY 2 GIVING LIM.

           PERFORM VARYING CNT FROM 1 BY 1 UNTIL CNT > LIM
               DIVIDE NUM BY CNT GIVING DIV REMAINDER REM
               IF REM = 0
                   MOVE CNT TO DIS
                   PERFORM SHODIS
               END-IF
           END-PERFORM.

           MOVE NUM TO DIS.
           PERFORM SHODIS.
           STOP RUN.

       SHODIS.
           MOVE ZERO TO ZRS.
           INSPECT DIS TALLYING ZRS FOR LEADING ZERO.
           DISPLAY DIS(ZRS + 1:)
           EXIT PARAGRAPH.

       END PROGRAM FACTORS.

compute the factors of a given positive integer, excluding zero and negative numbers. The factors are the positive integers that can divide the input number to yield a positive integer. For prime numbers, the factors are 1 and the number itself.


       identification division.
       program-id. AlignColumns.

       data division.
       working-storage section.
      *>-> Constants
       78 MAX-LINES value 6.
       78 MAX-LINE-SIZE value 66.
       78 MAX-COLUMNS value 12.
       78 MAX-COLUMN-SIZE value 16.
      *>-> Indexes
       01 w-idx                   pic is 9(2).
       01 w-idy                   pic is 9(2).
       01 w-pos                   pic is 9(3).
      *>-> Data structures
       01 w-lines.
          05 w-line               pic is x(MAX-LINE-SIZE) occurs MAX-LINES.
       01 w-column-sizes.
          05 w-column-size        pic is 99 occurs MAX-COLUMNS value zeros.
       01 w-matrix.
          05 filler               occurs MAX-LINES.
             10 filler            occurs MAX-COLUMNS.
                15 w-content      pic is x(MAX-COLUMN-SIZE).
      *>-> Output
       01 w-line-out              pic is x(120).
      *>-> Data alignment
       01 w-alignment             pic is x(1).
          88 alignment-left       value is "L".
          88 alignment-center     value is "C".
          88 alignment-right      value is "R".

       procedure division.
       main.
           move "Given$a$text$file$of$many$lines,$where$fields$within$a$line$" to w-line(1)
           move "are$delineated$by$a$single$'dollar'$character,$write$a$program" to w-line(2)
           move "that$aligns$each$column$of$fields$by$ensuring$that$words$in$each$" to w-line(3)
           move "column$are$separated$by$at$least$one$space." to w-line(4)
           move "Further,$allow$for$each$word$in$a$column$to$be$either$left$" to w-line(5)
           move "justified,$right$justified,$or$center$justified$within$its$column." to w-line(6)
           perform calculate-size-columns
           set alignment-left to true
           perform show-content
           set alignment-center to true
           perform show-content
           set alignment-right to true
           perform show-content
           goback
           .
       calculate-size-columns.
           perform
              varying             w-idx from 1 by 1
                 until            w-idx > MAX-LINES
              unstring w-line(w-idx) delimited by "$" into w-content(w-idx, 1), w-content(w-idx, 2),
                  w-content(w-idx, 3), w-content(w-idx, 4), w-content(w-idx, 5), w-content(w-idx, 6),
                  w-content(w-idx, 7), w-content(w-idx, 8), w-content(w-idx, 9), w-content(w-idx, 10),
                  w-content(w-idx, 11), w-content(w-idx, 12),
              perform
                 varying          w-idy from 1 by 1
                    until         w-idy > MAX-COLUMNS
                 if function stored-char-length(w-content(w-idx, w-idy)) > w-column-size(w-idy)
                    move function stored-char-length(w-content(w-idx, w-idy)) to w-column-size(w-idy)
                 end-if
              end-perform
           end-perform
           .
       show-content.
           move all "-" to w-line-out
           display w-line-out
           perform
              varying             w-idx from 1 by 1
                 until            w-idx > MAX-LINES
              move spaces to w-line-out
              move 1 to w-pos
              perform
                 varying          w-idy from 1 by 1
                    until         w-idy > MAX-COLUMNS
                 call "C$JUSTIFY" using w-content(w-idx, w-idy)(1:w-column-size(w-idy)), w-alignment
                 move w-content(w-idx, w-idy) to w-line-out(w-pos:w-column-size(w-idy))
                 compute w-pos = w-pos + w-column-size(w-idy) + 1
              end-perform
              display w-line-out
           end-perform
           .

The code reads a text file with lines separated by a dollar character. It aligns each column of fields by ensuring at least one space between words in each column. It also allows each word in a column to be left, right, or center justified. The minimum space between columns is computed from the text, not hard-coded. Trailing dollar characters or consecutive spaces at the end of lines do not affect the alignment. The output is suitable for viewing in a mono-spaced font on a plain text editor or basic terminal.


Works with: COBOL-85

FORMAT IDENTIFICATION DIVISION.
       PROGRAM-ID. rot-13.

       DATA DIVISION.
       LINKAGE SECTION.
       77  in-str       PIC X(100).
       77  out-str      PIC X(100).

       PROCEDURE DIVISION USING BY REFERENCE in-str, out-str.
           MOVE in-str TO out-str
           INSPECT out-str
               CONVERTING "abcdefghijklmnopqrstuvwxyz"
               TO "nopqrstuvwxyzabcdefghijklm"
           INSPECT out-str
               CONVERTING "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
               TO "NOPQRSTUVWXYZABCDEFGHIJKLM"
           EXIT PROGRAM.

       END PROGRAM rot-13.

Works with: COBOL 2002

IDENTIFICATION DIVISION.
FUNCTION-ID. rot-13.

DATA DIVISION.
LOCAL-STORAGE SECTION.
01  STR-LENGTH   CONSTANT AS 100.
01  normal-lower CONSTANT AS "abcdefghijklmnopqrstuvwxyz".
01  rot13-lower  CONSTANT AS "nopqrstuvwxyzabcdefghijklm".
01  normal-upper CONSTANT AS "ABCDEFGHIJKLMNOPQRSTUVWXYZ".
01  rot13-upper  CONSTANT AS "NOPQRSTUVWXYZABCDEFGHIJKLM".
LINKAGE SECTION.
77  in-str       PICTURE IS X(STR-LENGTH).
77  out-str      PICTURE IS X(STR-LENGTH).

PROCEDURE DIVISION USING in-str, RETURNING out-str.
    MOVE in-str TO out-str
    INSPECT out-str CONVERTING normal-lower TO rot13-lower
    INSPECT out-str CONVERTING normal-upper TO rot13-upper
    GOBACK.

END FUNCTION rot-13.

The code implements a rot-13 function, which is a mono-alphabetic substitution cipher that replaces each letter in the ASCII alphabet with the letter 13 positions ahead, wrapping from 'z' to 'a' as needed. This function is optionally wrapped in a utility program similar to a common UNIX utility, processing files line by line or acting as a filter on its standard input. It preserves case and passes all non-alphabetic characters without alteration. The code also includes a modern version with a user-defined function and compile-time constants, following strict COBOL-85 implementation.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. Display-Triangle.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  Outer-Counter PIC 9.
       01  Inner-Counter PIC 9.

       PROCEDURE DIVISION.
       PERFORM VARYING Outer-Counter FROM 1 BY 1 UNTIL 5 < Outer-Counter

           PERFORM VARYING Inner-Counter FROM 1 BY 1
                   UNTIL Outer-Counter < Inner-Counter
               DISPLAY "*" NO ADVANCING
           END-PERFORM

           DISPLAY "" *> Output a newline
       END-PERFORM

       GOBACK
       .

demonstrate how to use nested for loops to print a specific pattern. The number of iterations in the inner loop is controlled by the outer loop, resulting in a pattern of increasing asterisks.


Works with: COBOL version 2002
Works with: OpenCOBOL version 1.1

       *>* Ethiopian multiplication

       IDENTIFICATION DIVISION.
       PROGRAM-ID. ethiopian-multiplication.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       01  l                  PICTURE 9(10) VALUE 17.
       01  r                  PICTURE 9(10) VALUE 34.
       01  ethiopian-multiply PICTURE 9(20).
       01  product            PICTURE 9(20).
       PROCEDURE DIVISION.
         CALL "ethiopian-multiply" USING
           BY CONTENT l, BY CONTENT r,
           BY REFERENCE ethiopian-multiply
         END-CALL
         DISPLAY ethiopian-multiply END-DISPLAY
         MULTIPLY l BY r GIVING product END-MULTIPLY
         DISPLAY product END-DISPLAY
         STOP RUN.
       END PROGRAM ethiopian-multiplication.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. ethiopian-multiply.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       01  evenp   PICTURE 9.
         88 even   VALUE 1.
         88 odd    VALUE 0.
       LINKAGE SECTION.
       01  l       PICTURE 9(10).
       01  r       PICTURE 9(10).
       01  product PICTURE 9(20) VALUE ZERO.
       PROCEDURE DIVISION using l, r, product.
         MOVE ZEROES TO product
         PERFORM UNTIL l EQUAL ZERO
           CALL "evenp" USING
             BY CONTENT l,
             BY REFERENCE evenp
           END-CALL
           IF odd
             ADD r TO product GIVING product END-ADD
           END-IF
           CALL "halve" USING
             BY CONTENT l,
             BY REFERENCE l
           END-CALL
           CALL "twice" USING
             BY CONTENT r,
             BY REFERENCE r
           END-CALL
         END-PERFORM
         GOBACK.
       END PROGRAM ethiopian-multiply.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. halve.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       LINKAGE SECTION.
       01  n   PICTURE 9(10).
       01  m   PICTURE 9(10).
       PROCEDURE DIVISION USING n, m.
         DIVIDE n BY 2 GIVING m END-DIVIDE
         GOBACK.
       END PROGRAM halve.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. twice.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       LINKAGE SECTION.
       01  n   PICTURE 9(10).
       01  m   PICTURE 9(10).
       PROCEDURE DIVISION USING n, m.
         MULTIPLY n by 2 GIVING m END-MULTIPLY
         GOBACK.
       END PROGRAM twice.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. evenp.
       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       01  q   PICTURE 9(10).
       LINKAGE SECTION.
       01  n   PICTURE 9(10).
       01  m   PICTURE 9(1).
         88 even   VALUE 1.
         88 odd    VALUE 0.
       PROCEDURE DIVISION USING n, m.
         DIVIDE n BY 2 GIVING q REMAINDER m END-DIVIDE
         SUBTRACT m FROM 1 GIVING m END-SUBTRACT
         GOBACK.
       END PROGRAM evenp.

The code defines three functions for halving an integer, doubling an integer, and checking if an integer is even. It then uses these functions to implement the Ethiopian multiplication method. This method involves repeatedly halving the first number and doubling the second number, discarding rows where the first number is even, and summing the remaining values in the second column to get the product of the original two numbers. In the case of COBOL, the doubling function is named 'twice' due to 'double' being a reserved word.


        >>SOURCE FORMAT FREE
*> This code is dedicated to the public domain
*> This is GNUCobol 2.0
identification division.
program-id. twentyfoursolve.
environment division.
configuration section.
repository. function all intrinsic.
input-output section.
file-control.
    select count-file
        assign to count-file-name
        file status count-file-status
        organization line sequential.
data division.
file section.
fd  count-file.
01  count-record pic x(7).

working-storage section.
01  count-file-name pic x(64) value 'solutioncounts'.
01  count-file-status pic xx.

01  command-area.
    03  nd pic 9.
    03  number-definition.
        05  n occurs 4 pic 9.
    03  number-definition-9 redefines number-definition
        pic 9(4).
    03  command-input pic x(16).
    03  command pic x(5).
    03  number-count pic 9999.
    03  l1 pic 99.
    03  l2 pic 99.
    03  expressions pic zzz,zzz,zz9.

01  number-validation.
    03  px pic 99.
    03  permutations value
          '1234'
        & '1243'
        & '1324'
        & '1342'
        & '1423'
        & '1432'

        & '2134'
        & '2143'
        & '2314'
        & '2341'
        & '2413'
        & '2431'

        & '3124'
        & '3142'
        & '3214'
        & '3241'
        & '3423'
        & '3432'

        & '4123'
        & '4132'
        & '4213'
        & '4231'
        & '4312'
        & '4321'.
        05  permutation occurs 24 pic x(4).
    03  cpx pic 9.
    03  current-permutation pic x(4).
    03  od1 pic 9.
    03  od2 pic 9.
    03  od3 pic 9.
    03  operator-definitions pic x(4) value '+-*/'.
    03  cox pic 9.
    03  current-operators pic x(3).
    03  rpn-forms value
          'nnonono'
        & 'nnonnoo'
        & 'nnnonoo'
        & 'nnnoono'
        & 'nnnnooo'.
        05  rpn-form occurs 5 pic x(7).
    03  rpx pic 9.
    03  current-rpn-form pic x(7).

01  calculation-area.
    03  oqx pic 99.
    03  output-queue pic x(7).
    03  work-number pic s9999.
    03  top-numerator pic s9999 sign leading separate.
    03  top-denominator pic s9999 sign leading separate.
    03  rsx pic 9.
    03  result-stack occurs 8.
        05  numerator pic s9999.
        05  denominator pic s9999.
    03  divide-by-zero-error pic x.

01  totals.
    03  s pic 999.
    03  s-lim pic 999 value 600.
    03  s-max pic 999 value 0.
    03  solution occurs 600 pic x(7).
    03  sc pic 999.
    03  sc1 pic 999.
    03  sc2 pic 9.
    03  sc-max pic 999 value 0.
    03  sc-lim pic 999 value 600.
    03  solution-counts value zeros.
        05  solution-count occurs 600 pic 999.
    03  ns pic 9999.
    03  ns-max pic 9999 value 0.
    03  ns-lim pic 9999 value 6561.
    03  number-solutions occurs 6561.
        05 ns-number pic x(4).
        05 ns-count pic 999.
    03  record-counts pic 9999.
    03  total-solutions pic 9999.

01  infix-area.
    03  i pic 9.
    03  i-s pic 9.
    03  i-s1 pic 9.
    03  i-work pic x(16).
    03  i-stack occurs 7 pic x(13).

procedure division.
start-twentyfoursolve.
    display 'start twentyfoursolve'
    perform display-instructions
    perform get-command
    perform until command-input = spaces
        display space
        initialize command number-count
        unstring command-input delimited by all space
            into command number-count
        move command-input to number-definition
        move spaces to command-input
        evaluate command
        when 'h'
        when 'help'
            perform display-instructions
        when 'list'
            if ns-max = 0
                perform load-solution-counts
            end-if
            perform list-counts
        when 'show'
            if ns-max = 0
                perform load-solution-counts
            end-if
            perform show-numbers
        when other
            if number-definition-9 not numeric
                display 'invalid number'
            else
                perform get-solutions
                perform display-solutions
            end-if
        end-evaluate
        if command-input = spaces
            perform get-command
        end-if
    end-perform
    display 'exit twentyfoursolve'
    stop run
    .
display-instructions.
    display space
    display 'enter a number <n> as four integers from 1-9 to see its solutions'
    display 'enter list to see counts of solutions for all numbers'
    display 'enter show <n> to see numbers having <n> solutions'
    display '<enter> ends the program'
    .
get-command.
    display space
    move spaces to command-input
    display '(h for help)?' with no advancing
    accept command-input
    .
ask-for-more.
    display space
    move 0 to l1
    add 1 to l2
    if l2 = 10
        display 'more (<enter>)?' with no advancing
        accept command-input
        move 0 to l2
    end-if
    .
list-counts.
    add 1 to sc-max giving sc
    display 'there are ' sc ' solution counts'
    display space
    display 'solutions/numbers'
    move 0 to l1
    move 0 to l2
    perform varying sc from 1 by 1 until sc > sc-max
    or command-input <> spaces
        if solution-count(sc) > 0
            subtract 1 from sc giving sc1 *> offset to capture zero counts
            display sc1 '/' solution-count(sc) space with no advancing
            add 1 to l1
            if l1 = 8
                perform ask-for-more
            end-if
        end-if
    end-perform
    if l1 > 0
        display space
    end-if
    .
show-numbers. *> with number-count solutions
    add 1 to number-count giving sc1 *> offset for zero count
    evaluate true
    when number-count >= sc-max
        display 'no number has ' number-count ' solutions'
        exit paragraph
    when solution-count(sc1) = 1 and number-count = 1
        display '1 number has 1 solution'
    when solution-count(sc1) = 1
        display '1 number has ' number-count ' solutions'
    when number-count = 1
        display solution-count(sc1) ' numbers have 1 solution'
    when other
        display solution-count(sc1) ' numbers have ' number-count ' solutions'
    end-evaluate
    display space
    move 0 to l1
    move 0 to l2
    perform varying ns from 1 by 1 until ns > ns-max
    or command-input <> spaces
        if ns-count(ns) = number-count
            display ns-number(ns) space with no advancing
            add 1 to l1
            if l1 = 14
                perform ask-for-more
            end-if
        end-if
    end-perform
    if l1 > 0
        display space
    end-if
    .
display-solutions.
    evaluate s-max
    when 0 display number-definition ' has no solutions'
    when 1 display number-definition ' has 1 solution'
    when other display number-definition ' has ' s-max ' solutions'
    end-evaluate
    display space
    move 0 to l1
    move 0 to l2
    perform varying s from 1 by 1 until s > s-max
    or command-input <> spaces
        *> convert rpn solution(s) to infix
        move 0 to i-s
        perform varying i from 1 by 1 until i > 7
            if solution(s)(i:1) >= '1' and <= '9'
                add 1 to i-s
                move solution(s)(i:1) to i-stack(i-s)
            else
                subtract 1 from i-s giving i-s1
                move spaces to i-work
                string '(' i-stack(i-s1) solution(s)(i:1) i-stack(i-s) ')'
                    delimited by space into i-work
                move i-work to i-stack(i-s1)
                subtract 1 from i-s
            end-if
        end-perform
        display solution(s) space i-stack(1) space space with no advancing
        add 1 to l1
        if l1 = 3
            perform ask-for-more
        end-if
    end-perform
    if l1 > 0
        display space
    end-if
    .
load-solution-counts.
    move 0 to ns-max *> numbers and their solution count
    move 0 to sc-max *> solution counts
    move spaces to count-file-status
    open input count-file
    if count-file-status <> '00'
        perform create-count-file
        move 0 to ns-max *> numbers and their solution count
        move 0 to sc-max *> solution counts
        open input count-file
    end-if
    read count-file
    move 0 to record-counts
    move zeros to solution-counts
    perform until count-file-status <> '00'
        add 1 to record-counts
        perform increment-ns-max
        move count-record to number-solutions(ns-max)
        add 1 to ns-count(ns-max) giving sc *> offset 1 for zero counts
        if sc > sc-lim
            display 'sc ' sc ' exceeds sc-lim ' sc-lim
            stop run
        end-if
        if sc > sc-max
            move sc to sc-max
        end-if
        add 1 to solution-count(sc)
        read count-file
    end-perform
    close count-file
    .
create-count-file.
    open output count-file
    display 'Counting solutions for all numbers'
    display 'We will examine 9*9*9*9 numbers'
    display 'For each number we will examine 4! permutations of the digits'
    display 'For each permutation we will examine 4*4*4 combinations of operators'
    display 'For each permutation and combination we will examine 5 rpn forms'
    display 'We will count the number of unique solutions for the given number'
    display 'Each number and its counts will be written to file ' trim(count-file-name)
    compute expressions = 9*9*9*9*factorial(4)*4*4*4*5
    display 'So we will evaluate ' trim(expressions) ' statements'
    display 'This will take a few minutes'
    display 'In the future if ' trim(count-file-name) ' exists, this step will be bypassed'
    move 0 to record-counts
    move 0 to total-solutions
    perform varying n(1) from 1 by 1 until n(1) = 0
        perform varying n(2) from 1 by 1 until n(2) = 0
            display n(1) n(2) '..' *> show progress
            perform varying n(3) from 1 by 1 until n(3) = 0
                perform varying n(4) from 1 by 1 until n(4) = 0
                    perform get-solutions
                    perform increment-ns-max
                    move number-definition to ns-number(ns-max)
                    move s-max to ns-count(ns-max)
                    move number-solutions(ns-max) to count-record
                    write count-record
                    add s-max to total-solutions
                    add 1 to record-counts
                    add 1 to ns-count(ns-max) giving sc *> offset by 1 for zero counts
                    if sc > sc-lim
                        display 'error: ' sc ' solution count exceeds ' sc-lim
                        stop run
                    end-if
                    add 1 to solution-count(sc)
                end-perform
            end-perform
        end-perform
    end-perform
    close count-file
    display record-counts ' numbers and counts written to ' trim(count-file-name)
    display total-solutions ' total solutions'
    display space
    .
increment-ns-max.
    if ns-max >= ns-lim
        display 'error: numbers exceeds ' ns-lim
        stop run
    end-if
    add 1 to ns-max
    .
get-solutions.
    move 0 to s-max
    perform varying px from 1 by 1 until px > 24
        move permutation(px) to current-permutation
        perform varying od1 from 1 by 1 until od1 > 4
            move operator-definitions(od1:1) to current-operators(1:1)
            perform varying od2 from 1 by 1 until od2 > 4
                move operator-definitions(od2:1) to current-operators(2:1)
                perform varying od3 from 1 by 1 until od3 > 4
                    move operator-definitions(od3:1) to current-operators(3:1)
                    perform varying rpx from 1 by 1 until rpx > 5
                        move rpn-form(rpx) to current-rpn-form
                        move 0 to cpx cox
                        move spaces to output-queue
                        perform varying oqx from 1 by 1 until oqx > 7
                            if current-rpn-form(oqx:1) = 'n'
                                add 1 to cpx
                                move current-permutation(cpx:1) to nd
                                move n(nd) to output-queue(oqx:1)
                            else
                                add 1 to cox
                                move current-operators(cox:1) to output-queue(oqx:1)
                            end-if
                        end-perform
                        perform evaluate-rpn
                        if divide-by-zero-error = space
                        and 24 * top-denominator = top-numerator
                            perform varying s from 1 by 1 until s > s-max
                            or solution(s) = output-queue
                                continue
                            end-perform
                            if s > s-max
                                if s >= s-lim
                                    display 'error: solutions ' s ' for ' number-definition ' exceeds ' s-lim
                                    stop run
                                end-if
                                move s to s-max
                                move output-queue to solution(s-max)
                            end-if
                        end-if
                    end-perform
                end-perform
            end-perform
        end-perform
    end-perform
    .
evaluate-rpn.
    move space to divide-by-zero-error
    move 0 to rsx *> stack depth
    perform varying oqx from 1 by 1 until oqx > 7
        if output-queue(oqx:1) >= '1' and <= '9'
            *> push the digit onto the stack
            add 1 to rsx
            move top-numerator to numerator(rsx)
            move top-denominator to denominator(rsx)
            move output-queue(oqx:1) to top-numerator
            move 1 to top-denominator
        else
            *> apply the operation
            evaluate output-queue(oqx:1)
            when '+'
                compute top-numerator = top-numerator * denominator(rsx)
                    + top-denominator * numerator(rsx)
                compute top-denominator = top-denominator * denominator(rsx)
            when '-'
                compute top-numerator = top-denominator * numerator(rsx)
                    - top-numerator * denominator(rsx)
                compute top-denominator = top-denominator * denominator(rsx)
            when '*'
                compute top-numerator = top-numerator * numerator(rsx)
                compute top-denominator = top-denominator * denominator(rsx)
            when '/'
                compute work-number = numerator(rsx) * top-denominator
                compute top-denominator = denominator(rsx) * top-numerator
                if top-denominator = 0
                    move 'y' to divide-by-zero-error
                    exit paragraph
                end-if
                move work-number to top-numerator
            end-evaluate
            *> pop the stack
            subtract 1 from rsx
        end-if
    end-perform
    .
end program twentyfoursolve.

The code accepts four digits, either from user input or randomly generated, and calculates arithmetic expressions following the 24 game rules. It also displays examples of the solutions it generates.


MOVE FUNCTION FACTORIAL(num) TO result

Works with: GnuCOBOL
       IDENTIFICATION DIVISION.
       FUNCTION-ID. factorial_iterative.

       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       01  i      PIC 9(38).

       LINKAGE SECTION.
       01  n      PIC 9(38).
       01  ret    PIC 9(38).

       PROCEDURE DIVISION USING BY VALUE n RETURNING ret.
           MOVE 1 TO ret

           PERFORM VARYING i FROM 2 BY 1 UNTIL n < i
               MULTIPLY i BY ret
           END-PERFORM

           GOBACK.

       END FUNCTION factorial_iterative.

Works with: Visual COBOL
Works with: GnuCOBOL
       IDENTIFICATION DIVISION.
       FUNCTION-ID. factorial_recursive.

       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       01  prev-n PIC 9(38).

       LINKAGE SECTION.
       01  n      PIC 9(38).
       01  ret    PIC 9(38).

       PROCEDURE DIVISION USING BY VALUE n RETURNING ret.
           IF n = 0
               MOVE 1 TO ret
           ELSE
               SUBTRACT 1 FROM n GIVING prev-n
               MULTIPLY n BY factorial_recursive(prev-n) GIVING ret
           END-IF

           GOBACK.

       END FUNCTION factorial_recursive.
Works with: GnuCOBOL
       IDENTIFICATION DIVISION.
       PROGRAM-ID. factorial_test.

       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       REPOSITORY.
           FUNCTION factorial_iterative
           FUNCTION factorial_recursive.

       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       01  i      PIC 9(38).

       PROCEDURE DIVISION.
           DISPLAY
               "i = "
               WITH NO ADVANCING
           END-DISPLAY.
           ACCEPT i END-ACCEPT.
           DISPLAY SPACE END-DISPLAY.

           DISPLAY
               "factorial_iterative(i) = "
               factorial_iterative(i)
           END-DISPLAY.

           DISPLAY
               "factorial_recursive(i) = "
               factorial_recursive(i)
           END-DISPLAY.

           GOBACK.

       END PROGRAM factorial_test.

The code is a function that calculates the factorial of a given number. It can be implemented either iteratively or recursively. The function does not necessarily handle negative input errors. It does not need to check for negative parameters as they are unsigned. The function is related to the task of generating Primorial numbers. In COBOL, it uses an intrinsic function to return the factorial of its argument.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. RANDOM.
       AUTHOR.  Bill Gunshannon
       INSTALLATION.  Home.
       DATE-WRITTEN.  14 January 2022.
      ************************************************************
      ** Program Abstract:
      **   Able to get the Mean to be really close to 1.0 but
      **     couldn't get the Standard Deviation any closer than
      **     .3 to .4.
      ************************************************************

       DATA DIVISION.

       WORKING-STORAGE SECTION.

       01  Sample-Size          PIC 9(5)         VALUE 1000.
       01  Total                PIC 9(10)V9(5)  VALUE 0.0.
       01  Arith-Mean           PIC 999V999  VALUE 0.0.
       01  Std-Dev              PIC 999V999  VALUE 0.0.
       01  Seed                 PIC 999V999.
       01  TI                   PIC 9(8).

       01  Idx                  PIC 99999     VALUE 0.
       01  Intermediate         PIC 9(10)V9(5)  VALUE 0.0.
       01  Rnd-Work.
           05  Rnd-Tbl
                   OCCURS 1 TO 99999 TIMES DEPENDING ON Sample-Size.
               10  Rnd              PIC 9V9999999  VALUE 0.0.

       PROCEDURE DIVISION.

       Main-Program.
           ACCEPT TI FROM TIME.
           MOVE FUNCTION RANDOM(TI) TO Seed.
           PERFORM WITH TEST AFTER VARYING Idx
                   FROM 1 BY 1
                   UNTIL Idx = Sample-Size
              COMPUTE Intermediate =
                           (FUNCTION RANDOM() * 2.01)
              MOVE Intermediate TO Rnd(Idx)
           END-PERFORM.
           PERFORM WITH TEST AFTER VARYING Idx
                   FROM 1 BY 1
                   UNTIL Idx = Sample-Size
              COMPUTE Total = Total + Rnd(Idx)
           END-PERFORM.

           COMPUTE Arith-Mean = Total / Sample-Size.
           DISPLAY "Mean: " Arith-Mean.

           PERFORM WITH TEST AFTER VARYING Idx
                   FROM 1 BY 1
                   UNTIL Idx = Sample-Size
              COMPUTE Intermediate =
                      Intermediate + (Rnd(Idx) - Arith-Mean) ** 2
           END-PERFORM.
              COMPUTE Std-Dev = Intermediate / Sample-Size.

           DISPLAY "Std-Dev: " Std-Dev.

           STOP RUN.

       END PROGRAM RANDOM.

generate a collection of 1000 normally distributed pseudo-random numbers with a mean of 1.0 and a standard deviation of 0.5.


Works with: GNU Cobol version 2.0
Works with: Visual COBOL
       IDENTIFICATION DIVISION.
       PROGRAM-ID. input-loop.

       ENVIRONMENT DIVISION.
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
           SELECT in-stream ASSIGN TO KEYBOARD *> or any other file/stream
               ORGANIZATION LINE SEQUENTIAL
               FILE STATUS in-stream-status.

       DATA DIVISION.
       FILE SECTION.
       FD  in-stream.
       01  stream-line                 PIC X(80).

       WORKING-STORAGE SECTION.
       01  in-stream-status            PIC 99.
           88  end-of-stream           VALUE 10.

       PROCEDURE DIVISION.
           OPEN INPUT in-stream

           PERFORM UNTIL EXIT
               READ in-stream
                   AT END
                       EXIT PERFORM
               END-READ
               DISPLAY stream-line
           END-PERFORM

           CLOSE in-stream
           .
       END PROGRAM input-loop.

"Continuously read words or lines from a text stream until there is no more data available."


       WORKING-STORAGE SECTION.
       01  WS-CURRENT-DATE-FIELDS.
           05  WS-CURRENT-DATE.
               10  WS-CURRENT-YEAR    PIC  9(4).
               10  WS-CURRENT-MONTH   PIC  9(2).
               10  WS-CURRENT-DAY     PIC  9(2).
           05  WS-CURRENT-TIME.
               10  WS-CURRENT-HOUR    PIC  9(2).
               10  WS-CURRENT-MINUTE  PIC  9(2).
               10  WS-CURRENT-SECOND  PIC  9(2).
               10  WS-CURRENT-MS      PIC  9(2).
           05  WS-DIFF-FROM-GMT       PIC S9(4).

       PROCEDURE DIVISION.
           MOVE FUNCTION CURRENT-DATE TO WS-CURRENT-DATE-FIELDS.

the system time in a specified unit. This can be used for debugging, network information, random number seeds, or program performance. The time is retrieved either by a system command or a built-in language function. It is related to the task of date formatting and retrieving system time.


Works with: GNU Cobol version 2.0
       >>SOURCE FREE
IDENTIFICATION DIVISION.
PROGRAM-ID. sedol.

ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
    SELECT sedol-file ASSIGN "sedol.txt"
        ORGANIZATION LINE SEQUENTIAL
        FILE STATUS sedol-file-status.

DATA DIVISION.
FILE SECTION.
FD  sedol-file.
01  sedol                               PIC X(6).

WORKING-STORAGE SECTION.
01  sedol-file-status                   PIC XX.
    88  sedol-file-ok                   VALUE "00".

01  digit-num                           PIC 9 COMP.

01  digit-weights-area                  VALUE "1317391".
    03  digit-weights                   PIC 9 OCCURS 7 TIMES.

01  weighted-sum-parts-area.
    03  weighted-sum-parts              PIC 9(3) COMP OCCURS 6 TIMES.

01  weighted-sum                        PIC 9(3) COMP.

01  check-digit                         PIC 9.

PROCEDURE DIVISION.
    OPEN INPUT sedol-file
    PERFORM UNTIL NOT sedol-file-ok
        READ sedol-file
            AT END
                EXIT PERFORM
        END-READ

        MOVE FUNCTION UPPER-CASE(sedol) TO sedol

        PERFORM VARYING digit-num FROM 1 BY 1 UNTIL digit-num > 6
            EVALUATE TRUE
                WHEN sedol (digit-num:1) IS ALPHABETIC-UPPER
                    IF sedol (digit-num:1) = "A" OR "E" OR "I" OR "O" OR "U"
                        DISPLAY "Invalid SEDOL: " sedol
                        EXIT PERFORM CYCLE
                    END-IF

                    COMPUTE weighted-sum-parts (digit-num) =
                        (FUNCTION ORD(sedol (digit-num:1)) - FUNCTION ORD("A")
                        + 10) * digit-weights (digit-num)

                WHEN sedol (digit-num:1) IS NUMERIC
                    MULTIPLY FUNCTION NUMVAL(sedol (digit-num:1))
                        BY digit-weights (digit-num)
                        GIVING weighted-sum-parts (digit-num)

                WHEN OTHER
                    DISPLAY "Invalid SEDOL: " sedol
                    EXIT PERFORM CYCLE
            END-EVALUATE
        END-PERFORM

        INITIALIZE weighted-sum
        PERFORM VARYING digit-num FROM 1 BY 1 UNTIL digit-num > 6
            ADD weighted-sum-parts (digit-num) TO weighted-sum
        END-PERFORM

        COMPUTE check-digit =
            FUNCTION MOD(10 - FUNCTION MOD(weighted-sum, 10), 10)

        DISPLAY sedol check-digit
    END-PERFORM

    CLOSE sedol-file
    .
END PROGRAM sedol.

The code takes a list of 6-digit SEDOLs as input, calculates the checksum digit for each SEDOL, and appends it to the end of the respective SEDOL. It also validates the input to ensure it contains only valid characters for a SEDOL string.


IDENTIFICATION DIVISION.
PROGRAM-ID. NTH-PROGRAM.
DATA DIVISION.
WORKING-STORAGE SECTION.
01  WS-NUMBER.
    05 N               PIC 9(8).
    05 LAST-TWO-DIGITS PIC 99.
    05 LAST-DIGIT      PIC 9.
    05 N-TO-OUTPUT     PIC Z(7)9.
    05 SUFFIX          PIC AA.
PROCEDURE DIVISION.
TEST-PARAGRAPH.
    PERFORM NTH-PARAGRAPH VARYING N FROM 0 BY 1 UNTIL N IS GREATER THAN 25.
    PERFORM NTH-PARAGRAPH VARYING N FROM 250 BY 1 UNTIL N IS GREATER THAN 265.
    PERFORM NTH-PARAGRAPH VARYING N FROM 1000 BY 1 UNTIL N IS GREATER THAN 1025.
    STOP RUN.
NTH-PARAGRAPH.
    MOVE 'TH' TO SUFFIX.
    MOVE N (7:2) TO LAST-TWO-DIGITS.
    IF LAST-TWO-DIGITS IS LESS THAN 4,
    OR LAST-TWO-DIGITS IS GREATER THAN 20,
    THEN PERFORM DECISION-PARAGRAPH.
    MOVE N TO N-TO-OUTPUT.
    DISPLAY N-TO-OUTPUT WITH NO ADVANCING.
    DISPLAY SUFFIX WITH NO ADVANCING.
    DISPLAY SPACE WITH NO ADVANCING.
DECISION-PARAGRAPH.
    MOVE N (8:1) TO LAST-DIGIT.
    IF LAST-DIGIT IS EQUAL TO 1 THEN MOVE 'ST' TO SUFFIX.
    IF LAST-DIGIT IS EQUAL TO 2 THEN MOVE 'ND' TO SUFFIX.
    IF LAST-DIGIT IS EQUAL TO 3 THEN MOVE 'RD' TO SUFFIX.

       0TH        1ST        2ND        3RD        4TH        5TH        6TH        7TH        8TH        9TH       10TH       11TH       12TH       13TH       14TH       15TH       16TH       17TH       18TH       19TH       20TH       21ST       22ND       23RD       24TH       25TH      250TH      251ST      252ND      253RD      254TH      255TH      256TH      257TH      258TH      259TH      260TH      261ST      262ND      263RD      264TH      265TH     1000TH     1001ST     1002ND     1003RD     1004TH     1005TH     1006TH     1007TH     1008TH     1009TH     1010TH     1011TH     1012TH     1013TH     1014TH     1015TH     1016TH     1017TH     1018TH     1019TH     1020TH     1021ST     1022ND     1023RD     1024TH     1025TH

The code is a function that takes a non-negative integer as input and returns a string representation of the number with its ordinal suffix. The function handles specific cases for numbers ending in 1, 2, 3 and numbers in the teens. The function is demonstrated with the ranges 0..25, 250..265, 1000..1025. The code directly extracts the last digit or two, leveraging COBOL's decimal number storage.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. Strip-Chars.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  Str-Size  CONSTANT 128.

       LOCAL-STORAGE SECTION.
       01  I       PIC 999.
       01  Str-Pos PIC 999.

       01  Offset  PIC 999.
       01  New-Pos PIC 999.

       01  Str-End PIC 999.

       LINKAGE SECTION.
       01  Str     PIC X(Str-Size).
       01  Chars-To-Replace PIC X(256).

       PROCEDURE DIVISION USING Str BY VALUE Chars-To-Replace.
       Main.
           PERFORM VARYING I FROM 1 BY 1
                   UNTIL Chars-To-Replace (I:1) = X"00"

               MOVE ZERO TO Offset

*              *> Overwrite the characters to remove by left-shifting
*              *> following characters over them.
               PERFORM VARYING Str-Pos FROM 1 BY 1
                       UNTIL Str-Size < Str-Pos
                   IF Str (Str-Pos:1) = Chars-To-Replace (I:1)
                       ADD 1 TO Offset
                   ELSE IF Offset NOT = ZERO
                       COMPUTE New-Pos = Str-Pos - Offset
                       MOVE Str (Str-Pos:1) TO Str (New-Pos:1)
                   END-IF
               END-PERFORM

*              *> Move spaces to characters at the end that have been
*              *> shifted over.
               COMPUTE Str-End = Str-Size - Offset
               MOVE SPACES TO Str (Str-End:Offset)
           END-PERFORM

           GOBACK
           .

The code defines a function that removes a specified set of characters from a given string. The function takes two arguments: the original string and the string of characters to be removed. The function then returns the original string with all instances of the specified characters removed.


       identification division.
       program-id. prepend.
       data division.
       working-storage section.
       1 str pic x(30) value "World!".
       1 binary.
        2 len pic 9(4) value 0.
        2 scratch pic 9(4) value 0.
       procedure division.
       begin.
           perform rev-sub-str
           move function reverse ("Hello ") to str (len + 1:)
           perform rev-sub-str
           display str
           stop run
           .

       rev-sub-str.
           move 0 to len scratch
           inspect function reverse (str)
           tallying scratch for leading spaces
               len for characters after space
           move function reverse (str (1:len)) to str
           .
       end program prepend.

Hello World!
Works with: GNU Cobol version 2.0
       >>SOURCE FREE
PROGRAM-ID. prepend.

DATA DIVISION.
WORKING-STORAGE SECTION.
01  str                                 PIC X(30) VALUE "world!".

PROCEDURE DIVISION.
    MOVE FUNCTION CONCATENATE("Hello, ", str) TO str
    DISPLAY str
    .
END PROGRAM prepend.

Creates a string variable with a specific text value, prepends another string literal to it, and displays the content of the variable. If possible, the operation is performed without referring to the variable twice in one expression.


Works with: GnuCOBOL
         >>SOURCE FORMAT FREE
*> This code is dedicated to the public domain
identification division.
program-id. dragon.
environment division.
configuration section.
repository. function all intrinsic.
data division.
working-storage section.
01  segment-length pic 9 value 2.
01  mark pic x value '.'.
01  segment-count pic 9999 value 513.

01  segment pic 9999.
01  point pic 9999 value 1.
01  point-max pic 9999.
01  point-lim pic 9999 value 8192.
01  dragon-curve.
    03  filler occurs 8192.
        05  ydragon pic s9999.
        05  xdragon pic s9999.

01  x pic s9999 value 1.
01  y pic S9999 value 1.

01  xdelta pic s9 value 1. *> start pointing east
01  ydelta pic s9 value 0.

01  x-max pic s9999 value -9999.
01  x-min pic s9999 value 9999.
01  y-max pic s9999 value -9999.
01  y-min pic s9999 value 9999.

01  n pic 9999.
01  r pic 9.

01  xupper pic s9999.
01  yupper pic s9999.

01  window-line-number pic 99.
01  window-width pic 99 value 64.
01  window-height pic 99 value 22.
01  window.
    03  window-line occurs 22.
        05  window-point occurs 64 pic x.

01  direction pic x.

procedure division.
start-dragon.

    if segment-count * segment-length > point-lim
        *> too many segments for the point-table
        compute segment-count = point-lim / segment-length
    end-if

    perform varying segment from 1 by 1
    until segment > segment-count

        *>===========================================
        *> segment = n * 2 ** b
        *> if mod(n,4) = 3, turn left else turn right
        *>===========================================

        *> calculate the turn
        divide 2 into segment giving n remainder r
        perform until r <> 0
            divide 2 into n giving n remainder r
        end-perform
        divide 2 into n giving n remainder r

        *> perform the turn
        evaluate r also xdelta also ydelta
        when 0 also 1 also 0  *> turn right from east
        when 1 also -1 also 0 *> turn left from west
            *> turn to south
            move 0 to xdelta
            move 1 to ydelta
        when 1 also 1 also 0  *> turn left from east
        when 0 also -1 also 0 *> turn right from west
            *> turn to north
            move 0 to xdelta
            move -1 to ydelta
        when 0 also 0 also 1  *> turn right from south
        when 1 also 0 also -1 *> turn left from north
            *> turn to west
            move 0 to ydelta
            move -1 to xdelta
        when 1 also 0 also 1  *> turn left from south
        when 0 also 0 also -1 *> turn right from north
            *> turn to east
            move 0 to ydelta
            move 1 to xdelta
        end-evaluate

        *> plot the segment points
        perform segment-length times
            add xdelta to x
            add ydelta to y

            move x to xdragon(point)
            move y to ydragon(point)

            add 1 to point
        end-perform

        *> update the limits for the display
        compute x-max = max(x, x-max)
        compute x-min = min(x, x-min)
        compute y-max = max(y, y-max)
        compute y-min = min(y, y-min)
        move point to point-max

    end-perform

    *>==========================================
    *> display the curve
    *> hjkl corresponds to left, up, down, right
    *> anything else ends the program
    *>==========================================

    move 1 to yupper xupper

    perform with test after
    until direction <> 'h' and 'j' and 'k' and 'l'

        *>==========================================
        *> (yupper,xupper) maps to window-point(1,1)
        *>==========================================

        *> move the window
        evaluate true
        when direction = 'h' *> move window left
        and xupper > x-min + window-width
           subtract 1 from xupper
        when direction = 'j' *> move window up
        and yupper < y-max - window-height
           add 1 to yupper
        when direction = 'k' *> move window down
        and yupper > y-min + window-height
           subtract 1 from yupper
        when direction = 'l' *> move window right
        and xupper < x-max - window-width
            add 1 to xupper
        end-evaluate

        *> plot the dragon points in the window
        move spaces to window
        perform varying point from 1 by 1
        until point > point-max
            if ydragon(point) >= yupper and < yupper + window-height
            and xdragon(point) >= xupper and < xupper + window-width
                *> we're in the window
                compute y = ydragon(point) - yupper + 1
                compute x =  xdragon(point) - xupper + 1
                move mark to window-point(y, x)
            end-if
         end-perform

         *> display the window
         perform varying window-line-number from 1 by 1
         until window-line-number > window-height
             display window-line(window-line-number)
         end-perform

         *> get the next window move or terminate
         display 'hjkl?' with no advancing
         accept direction
    end-perform

    stop run
    .
end program dragon.

generate a dragon curve fractal either directly or by writing it to an image file. The fractal is created using various algorithms such as recursive, successive approximation, iterative, and Lindenmayer system of expansions. The algorithms consider curl direction, bit transitions, and absolute X, Y coordinates. The code also includes functionality to test whether a given X,Y point or segment is on the curve. The code is adaptable to different programming languages and drawing methods.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. Guess-The-Number.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  Random-Num PIC 99.
       01  Guess      PIC 99.

       PROCEDURE DIVISION.
           COMPUTE Random-Num = 1 + (FUNCTION RANDOM * 10)
           DISPLAY "Guess a number between 1 and 10:"

           PERFORM FOREVER
               ACCEPT Guess

               IF Guess = Random-Num
                   DISPLAY "Well guessed!"
                   EXIT PERFORM
               ELSE
                   DISPLAY "That isn't it. Try again."
               END-IF
           END-PERFORM

           GOBACK
           .

"Implement a number guessing game where the computer selects a number between 1 and 10. The player is repeatedly prompted to guess the number until the correct number is guessed, upon which a 'Well guessed!' message is displayed and the program terminates. A conditional loop is used to facilitate repeated guessing."


identification division.
program-id. lower-case-alphabet-program.
data division.
working-storage section.
01  ascii-lower-case.
    05 lower-case-alphabet pic a(26).
    05 character-code      pic 999.
    05 loop-counter        pic 99.
procedure division.
control-paragraph.
    perform add-next-letter-paragraph varying loop-counter from 1 by 1
    until loop-counter is greater than 26.
    display lower-case-alphabet upon console.
    stop run.
add-next-letter-paragraph.
    add 97 to loop-counter giving character-code.
    move function char(character-code) to lower-case-alphabet(loop-counter:1).

generate an array, list, sequence, or string of all lower case ASCII characters from 'a' to 'z'. It demonstrates both accessing such a sequence from the standard library and manually generating a similar sequence. The code is written in a reliable style suitable for large programs and uses strong typing if available. It avoids manually enumerating all lowercase characters to prevent bugs. In the case of COBOL, the code uses mutable and subscripted strings to build the sequence in a loop.