ScreenSaver 5250 v1.618

Why a screen saver? We have system values set to disconnect jobs that have been inactive for over an hour. By running the screen saver, the system thinks the job is active.

There is a fair amount happening in this throwaway program:

I have a number of different versions. Some implement Quicksort iteratively, which allows for optimizations not possible with a recursive implementation. One uses CombSort, instead of Quicksort. Yet another consists of a batch/interactive combination, with a very very thin client using a DSPF DTAQ. And I'm working on another that user USRDFN DSPF, with 5250 data streams.



 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
 /*                                                                 */
 /*                    ScreenSaver5250                              */
 /*                                                                 */
 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
 /*    "If it's squinky, then you know it's BrilligWare!"           */
 /*                                                                 */
 /*    Source available at www.brilligware.com                      */
 /*    Brillig Enterprises (aka Chris Pando) (C)2022                */
 /*                                                                 */
 /*    This work is licensed under a Creative Commons               */
 /*    Attribution-NonCommercial-ShareAlike License:                */
 /*    http://creativecommons.org/licenses/by-nc-sa/2.0/legalcode   */
 /*                                                                 */
 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
 /*                                                                 */
 /* CRTBNDCL PGM(CPANDO/CP1329C)                                    */
 /*          SRCFILE(CPANDO/CPSRC)                                  */
 /*          SRCMBR(CP1329C)                                        */
 /*          DFTACTGRP(*NO)                                         */
 /*          ACTGRP(*NEW)                                           */
 /*          DBGVIEW(*ALL)                                          */
 /*                                                                 */
 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
 PGM
       SNDPGMMSG  MSG('CP1329R Request Boundary') +
                  TOPGMQ(*EXT) MSGTYPE(*RQS)
       RCVMSG     PGMQ(*EXT) MSGTYPE(*RQS) RMV(*NO)
       CALL       PGM(CP1329R)
       MONMSG     MSGID(CPF1907) EXEC(DO)
          RCVMSG     MSGTYPE(*EXCP)
       ENDDO
 ENDPGM


      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      *                                                                 *
      *                                                                 *
      *  CRTDSPF FILE(CPANDO/CP1329D)                                   *
      *          SRCFILE(CPANDO/CPSRC)                                  *
      *          SRCMBR(CP1329D)                                        *
      *          MAXDEV(1)                                              *
      *          WAITRCD(1)                                             *
      *                                                                 *
      * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
     A                                      DSPSIZ(24 80 *DS3)
     A                                      CF03(03 'EOJ')
     A                                      INVITE
     A          R DSPFMT
     A            FLD001        77   O  2  2
     A            FLD002        77   O  3  2
     A            FLD003        77   O  4  2
     A            FLD004        77   O  5  2
     A            FLD005        77   O  6  2
     A            FLD006        77   O  7  2
     A            FLD007        77   O  8  2
     A            FLD008        77   O  9  2
     A            FLD009        77   O 10  2
     A            FLD010        77   O 11  2
     A            FLD011        77   O 12  2
     A            FLD012        77   O 13  2
     A            FLD013        77   O 14  2
     A            FLD014        77   O 15  2
     A            FLD015        77   O 16  2
     A            FLD016        77   O 17  2
     A            FLD017        77   O 18  2
     A            FLD018        77   O 19  2
     A            FLD019        77   O 20  2
     A            FLD020        77   O 21  2
     A            FLD021        77   O 22  2
     A            FLD022        77   O 23  2

      //--------------------------------------------------------------------------------------------------------------//
      //                                                                                                              //
      //                                               ScreenSaver5250                                                //
      //                                                                                                              //
      //--------------------------------------------------------------------------------------------------------------//
       Ctl-Opt DftActGrp(*No) ActGrp(*Caller)
               debug(*Yes) option(*SrcStmt:*NoDebugIO:*NoUnRef)
               Main(cp1329r)                                                   ;
      //--------------------------------------------------------------------------------------------------------------//
      //                                                                                                              //
      // ... files ...                                                                                                //
      //                                                                                                              //
      //--------------------------------------------------------------------------------------------------------------//
       Dcl-F cp1329d WorkStn DevId(deviceID) MaxDev(*File) UsrOpn              ;
      //--------------------------------------------------------------------------------------------------------------//
      //                                                                                                              //
      //... procedure interfaces ...                                                                                  //
      //                                                                                                              //
      //--------------------------------------------------------------------------------------------------------------//
      //
      // ... bindable procedures ...
      //
       Dcl-PR random        ExtProc('CEERAN0')                                 ;
         *n                 Uns(10)                                            ;
         *n                 Float(8)                                           ;
         *n                 Char(12)                                           ;
       End-PR                                                                  ;
      //
      // ... external programs ...
      //
       Dcl-PR exec                                          ExtPgm('QCMDEXC')  ;
         *n             Char(1024)          Const           Options(*VarSize)  ;
         *n             Packed(15:5)        Const                              ;
       End-PR                                                                  ;
      //--------------------------------------------------------------------------------------------------------------//
      //                                                                                                              //
      // ... global variables/constants ...                                                                           //
      //                                                                                                              //
      //--------------------------------------------------------------------------------------------------------------//
      //                                                                                                              //
       Dcl-DS *n                                                               ;
         FLD001                                                                ;
         FLD002                                                                ;
         FLD003                                                                ;
         FLD004                                                                ;
         FLD005                                                                ;
         FLD006                                                                ;
         FLD007                                                                ;
         FLD008                                                                ;
         FLD009                                                                ;
         FLD010                                                                ;
         FLD011                                                                ;
         FLD012                                                                ;
         FLD013                                                                ;
         FLD014                                                                ;
         FLD015                                                                ;
         FLD016                                                                ;
         FLD017                                                                ;
         FLD018                                                                ;
         FLD019                                                                ;
         FLD020                                                                ;
         FLD021                                                                ;
         FLD022                                                                ;
         fld                Char(1694)      Pos(1)                             ;
       End-DS                                                                  ;
       Dcl-S  @arr          Zoned(3:0)      Dim(418)                           ;
       Dcl-S  @atr          Zoned(5:0)      Dim(418)                           ;
       Dcl-S  seed          Uns(10)                                            ;
       Dcl-S  floater       Float(8)                                           ;
       Dcl-S  fc            Char(12)                                           ;
       Dcl-S  $I            Zoned(3:0)                                         ;
       Dcl-S  $J            Zoned(3:0)                                         ;
       Dcl-S  $K            Zoned(3:0)                                         ;
       Dcl-S  $L            Zoned(5:0)                                         ;
      *
       Dcl-S  temp          Like(@arr)                                         ;
       Dcl-C  HEX20         x'20'                                              ;
       Dcl-C  HEX22         x'22'                                              ;
      //--------------------------------------------------------------------------------------------------------------//
      //                                                                                                              //
      //                                                  Procedures                                                  //
      //                                                                                                              //
      //--------------------------------------------------------------------------------------------------------------//
      //                                                   Mainline                                                   //
      //--------------------------------------------------------------------------------------------------------------//
       Dcl-Proc cp1329r                                                        ;
       init()                                                                  ;
       DoU ( *In03 )                                                           ;
         load()                                                                ;
         disp()                                                                ;
         sort( 1 : %Elem(@arr) )                                               ;
       EndDo                                                                   ;
       eoj()                                                                   ;

       Return                                                                  ;
       End-Proc                                                                ;
      //--------------------------------------------------------------------------------------------------------------//
       Dcl-Proc load                                                           ;
       For $I = 1 to %Elem(@arr)                                               ;
         @arr($I) = $I                                                         ;
         %SubSt(fld:@atr($I):1) = HEX20                                        ;
       EndFor                                                                  ;
       //
       // Fisher-Yates shuffle (Knuth variant)
       //
       For $I = %Elem(@arr) Downto 2                                           ;
         random(seed:floater:fc)                                               ;
         $J = floater * $I + 1                                                 ;
         If ($I <> $J)                                                         ;
            temp     = @arr($I)                                                ;
            @arr($I) = @arr($J)                                                ;
            @arr($J) = temp                                                    ;
         EndIf                                                                 ;
       EndFor                                                                  ;
       Return                                                                  ;
       End-Proc                                                                ;
      //--------------------------------------------------------------------------------------------------------------//
       Dcl-Proc Sort                                                           ;
         Dcl-PI *n                                                             ;
           $left         Zoned(3:0)                          Value             ;
           $right        Zoned(3:0)                          Value             ;
         End-PI                                                                ;
       Dcl-S  $I            Zoned(3:0)                                         ;
       Dcl-S  $J            Zoned(3:0)                                         ;
       Dcl-S  $K            Zoned(3:0)                                         ;
       Dcl-S  pivot         Zoned(3:0)                                         ;
       Select                                                                  ;
        When ( ($right - $left) = 0 )                                          ;
          ri(@arr($left))                                                      ;
          disp()                                                               ;
        When ( ($right - $left) = 1 )                                          ;
          If ( @arr($left) > @arr($right) )                                    ;
            temp         = @arr($left)                                         ;
            @arr($left)  = @arr($right)                                        ;
            @arr($right) = temp                                                ;
          EndIf                                                                ;
          ri(@arr($left))                                                      ;
          ri(@arr($right))                                                     ;
          disp()                                                               ;
        When ( ($right - $left) < 5 )                                          ;
          For $I = $left to $right-1                                           ;
            temp = *HiVal                                                      ;
            For $J = $I to $right                                              ;
              If ( @arr($J) < temp )                                           ;
                temp = @arr($J)                                                ;
                $K = $J                                                        ;
              EndIf                                                            ;
            EndFor                                                             ;
            If ( $K <> $I )                                                    ;
              @arr($K) = @arr($I)                                              ;
              @arr($I) = temp                                                  ;
            EndIf                                                              ;
            ri($I)                                                             ;
          EndFor                                                               ;
          ri($right)                                                           ;
          disp()                                                               ;
        Other                                                                  ;
          $K           = ($left + $right)/2                                    ;
          pivot        = @arr($K)                                              ;
          @arr($K)     = @arr($right)                                          ;
          @arr($right) = pivot                                                 ;
          ri(pivot)                                                            ;
          $I           = $left                                                 ;
          $J           = $right - 1                                            ;
          DoU ( $I = $J )                                                      ;
            DoW ( @arr($I) < pivot And ($I < $J) )                             ;
              $I += 1                                                          ;
            EndDo                                                              ;
            If ( $I < $J )                                                     ;
              DoW ( @arr($J) > pivot And ($I < $J) )                           ;
                $J -= 1                                                        ;
              EndDo                                                            ;
            EndIf                                                              ;
            If ($I = $J)                                                       ;
              Select                                                           ;
              When ($I = $left)                                                ;
                @arr($right) = @arr($I)                                        ;
                @arr($I)     = pivot                                           ;
                $K           = $left                                           ;
              When ($I = $right - 1 And pivot > @arr($I) )                     ;
                $K           = $right                                          ;
              Other                                                            ;
                @arr($right) = @arr($I)                                        ;
                @arr($I)     = pivot                                           ;
                $K           = $I                                              ;
              EndSl                                                            ;
            Else                                                               ;
              temp     = @arr($I)                                              ;
              @arr($I) = @arr($J)                                              ;
              @arr($J) = temp                                                  ;
            EndIf                                                              ;
          EndDo                                                                ;
          disp()                                                               ;
          //
          // time to recurse
          //
          Select                                                               ;
          When ( $K = $left )                                                  ;
            sort($left+1:$right)                                               ;
          When ( $K = $right )                                                 ;
            sort($left:$right-1)                                               ;
          Other                                                                ;
            sort($left:$K-1)                                                   ;
            sort($K+1:$right)                                                  ;
          EndSl                                                                ;

        EndSl                                                                  ;
        Return                                                                 ;
       End-Proc                                                                ;
      //--------------------------------------------------------------------------------------------------------------//
       Dcl-Proc disp                                                           ;

       Dcl-S  cmd            Char(256)       Inz('endrqs rqslvl(*Prv)')        ;
       Dcl-S  cmdLen         Packed(15:5)    Inz(%Len(cmd))                    ;

        $K = 1                                                                 ;
        For $K = 1 to 418                                                      ;
          %SubST( fld : @atr($K) + 1 : 3 ) = %Char(@arr($K))                   ;
        EndFor                                                                 ;
        Write dspfmt                                                           ;
        Read(E) cp1329d                                                        ;
        If ( *In03 )                                                           ;
          exec( cmd : cmdLen )                                                 ;// no return necessary
        EndIf                                                                  ;
        Return                                                                 ;
       End-Proc                                                                ;
      //--------------------------------------------------------------------------------------------------------------//
       Dcl-Proc ri                                                             ;
         Dcl-PI *n                                                             ;
           $I                Zoned(3:0)                      Value             ;
         End-PI                                                                ;
        %SubSt(fld:@atr($I):1) = HEX22                                         ;
        Return                                                                 ;
        End-Proc                                                               ;
      //--------------------------------------------------------------------------------------------------------------//
       Dcl-Proc init                                                           ;
       Open cp1329d                                                            ;
       //
       // @atr contains position to insert attribute byte
       //
       $K = 1                                                                  ;
       $L = 1                                                                  ;
       For $I = 1 to 22                                                        ;
         For $J = 1 to 19                                                      ;
           @atr($K) = $L                                                       ;
           $K +=1                                                              ;
           $L +=4                                                              ;
         EndFor                                                                ;
         $L +=1                                                                ;
       EndFor                                                                  ;
       End-Proc                                                                ;
      //--------------------------------------------------------------------------------------------------------------//
        Dcl-Proc eoj                                                           ;
        Close cp1329d                                                          ;
        End-Proc                                                               ;
      //--------------------------------------------------------------------------------------------------------------//


Valid HTML 3.2! Creative Commons License

BrilligWare/ chris@pando.org / revised August 2022