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 ;
//--------------------------------------------------------------------------------------------------------------//
