ACSL AGRAM - PC/370 - Keyboard Input

Previous AGRAM Card Game Posts:
ACLS AGRAM Card Game Exercise - Just for Fun
ACLS AGRAM Card Game - PC/370 Version

In this post I'll add another variation to the PC/370 version of the AGRAM Card Game. As I explained in the previous posts the AGRAM theme was part of my daughter's computer lab assignment. So far I created 3 program versions - SQR, WinBatch & PC/370 Assembler.

The previous PC/370 Assembler version used File I/O - An input file containing the Opponent/Dealer hands & an output file to log the results. Now I'll create a PC/370 version that builds an input screen & accepts direct keyboard entry - this will be similar in function to the WinBatch GUI version.

WinBatch Data Entry:

In WinBatch, the data entry screen was built using a GUI tool (called a Dialog Editor) which generates the code for you - just insert into the program. To utilize the screen just call the Dialog() function. Very simple.

   ButtonPushed         = Dialog("TD")

PC/370 Data Entry Screen:

PC/370 Assembler is much different. The developer is responsible for each character displayed & every key that is pressed. Video mode, X/Y coordinates, colors, boxes, reverse video, blinking, etc... These are all controlled by elaborate bit settings & DOS Interrupts that emulate MVS/370 Supervisor Calls and must be constructed properly in your program.

Above: Quick template I constructed where you can enter the Opponent Card & Dealer Hand (comma delimited string).

The full AGRAM program (TDAGRAM) including the logic of the game was displayed in the last post. This post will focus on the changes to convert it to Screen/Keyboard input. This version will be called TDAGRAM2.

Copybooks:
I'll start with a listing of the custom CopyBooks utilized by the program. These take care of all the critical Screen, Keyboard & Data Entry functions. I developed these in the fall of 1996.

***********************************************************************
*        COPYBOOKS                                                    *
***********************************************************************
         COPY  CPY/TDBOX.CPY                 COPYBOOK - BOX DISPLAY
         COPY  CPY/TDVID.CPY                 COPYBOOK - VIDEO UTILITY
         COPY  CPY/TDACC.CPY                 COPYBOOK - ACCEPT INPUT
         COPY  CPY/TDKBD.CPY                 COPYBOOK - KEYBOARD INPUT
         COPY  CPY/TDEDT.CPY                 COPYBOOK - EDITOR UTILITY
         COPY  CPY/TDKEY.CPY                 COPYBOOK - KEYSTROKES
         COPY  CPY/TDCLR.CPY                 COPYBOOK - COLORS
         COPY  CPY/TDSVC.CPY                 COPYBOOK - SUPERVISOR
***********************************************************************

Main Procedure:
The main logic is very similar to the prior version. Instead of reading from a file the SCREEN routine is called. If the <ESCAPE> key was pressed the process terminates. Otherwise the AGRAM logic kicks in - PARSE, SELECT & RESULT - then it loops back to display the screen again.

***********************************************************************
*        MAINLINE PROCEDURE                                           *
***********************************************************************
         PRINT NOGEN
         SVC   @TRACE                        ISSUE SUPERVISOR CALL
         DC    CL4'IOF '                     KEYBOARD INTERRUPT OFF
*
MAIN     EQU   *
         BAL   6,SCREEN                      BUILD SCREEN
*
         CLI   KEY,@K#ESC                    KEY = ESCAPE ???
         BE    MAINX                         YES - EXIT PLEASE
*
         BAL   6,PARSE                       PARSE RECORD
         BAL   6,SELECT                      SELECT CARD
         BAL   6,RESULT                      PRINT RESULT
*
         B     MAIN                          LOOP AGAIN
MAINX    EQU   *
         B     RETURN                        EXIT PROGRAM PLEASE
***********************************************************************

I designed the SCREEN Build routines to be dynamic - all activity is driven by a series of configuration tables. First, the screen is cleared using VRESET. Then a BOX is displayed around the screen (0,0 thru 23,79) using the VBOX routine. Static text is plotted & displayed using the VXYS routine & @WTO (Write to Operator) Supervisor Call. Finally, the ACCDAT routine is called to Accept Data entry of the two fields (OPPONENT & DEALER HAND). The table AKEY defines all the acceptable EXIT keys for the routine while the ATAB table defines each "edit" field on the page - address, length, coordinates, datatype & video settings. The <ESCAPE> & <F1> keys break out of the routine.

***********************************************************************
*        BUILD SCREEN                                                 *
***********************************************************************
         DC    F'0'                          RETURN ADDRESS SAVE AREA
SCREEN   EQU   *
         ST    6,*-4                         SAVE RETURN ADDRESS
*
         MVI   VBITS,@BKWT                   SET BG(BLACK)/FG(WHITE)
         BAL   6,VRESET                      CHANGE SCREEN ATTRIBUTES
*
*        DISPLAY SINGLE BOX
*
         MVC   VBX,VBOX2                     LOAD BOX FRAME
         MVC   VBXRC,BXTAB                   LOAD BOX COORDINATES
         BAL   6,VBOX                        DISPLAY BOX FRAME
*
*        DISPLAY SCREEN TEXT
*
         LA    5,SCTAB                       LOAD TABLE ADDRESS
SC1LP    EQU   *
         CLI   0(5),X'FF'                    END OF TABLE ???
         BE    SC1LPX                        YES - EXIT LOOP PLEASE
*
         MVC   VXYS,0(5)                     MOVE CURSOR POSITION
         BAL   6,VXYSET                      SET CURSOR POSITION
         L     2,4(5)                        LOAD MESSAGE ADDRESS
         SVC   @WTO                          ISSUE SUPERVISOR CALL
*
         LA    5,8(,5)                       BUMP TABLE POINTER
         B     SC1LP                         TEST NEXT TABLE ENTRY
SC1LPX   EQU   *
*
*        ACCEPT INPUT DATA
*
         MVC   ACCKEYX,=A(AKEY)              LOAD EXIT KEY TABLE
         LA    5,ATAB                        LOAD TABLE ADDRESS
SC2LP    EQU   *
         CLI   0(5),X'FF'                    END OF TABLE ???
         BNE   *+8                           NO  - CONTINUE PLEASE
         LA    5,ATAB                        LOAD TABLE ADDRESS
*
         MVC   ACCPARM,0(5)                  MOVE ACCEPT PARMS
         BAL   6,ACCDAT                      ACCEPT INPUT DATA
*
         CLI   KEY,@K#ESC                    KEY = ESCAPE ???
         BE    SC2LPX                        YES - EXIT LOOP PLEASE
         CLI   KEY,@K#F1                     KEY = F1 ???
         BE    SC2LPX                        YES - EXIT LOOP PLEASE
*
         CLI   KEY,@K#ARWU                   KEY = ARROW UP ???
         BE    SC2LPU                        YES - BUMP BACKWARDS
         CLI   KEY,@K#ARWL                   KEY = ARROW LEFT ???
         BE    SC2LPU                        YES - BUMP BACKWARDS
         CLI   KEY,@K#TABL                   KEY = TAB LEFT ???
         BE    SC2LPU                        YES - BUMP BACKWARDS
*
         LA    5,12(,5)                      BUMP TABLE POINTER
         B     SC2LP                         TEST NEXT TABLE ENTRY
SC2LPU   EQU   *
         SH    5,=Y(12)                      BUMP TABLE POINTER
         C     5,=A(ATAB)                    TABLE AT TOP ???
         BNL   SC2LP                         NO  - TEST NEXT ENTRY
         LA    5,ATABX-12                    LOAD LAST ENTRY ADDRESS
         B     SC2LP                         TEST NEXT TABLE ENTRY
SC2LPX   EQU   *
         MVI   VBITS,@BKWT                   SET BG(BLACK)/FG(WHITE)
         BAL   6,VRESET                      CHANGE SCREEN ATTRIBUTES
SCREENX  EQU   *
         L     6,SCREEN-4                    RESTORE LINK REGISTER
         BR    6                             BRANCH ON LINK REGISTER
***********************************************************************

Screen/Key Configuration Tables:
BXTAB defines the box coordinates used by the VBOX routine - here a simple 24x80 enclosure for the page. SCTAB writes static text to the screen using x/y coordinates & the address of static text field(s). Each static text definition ends in a "$" sign (required by WTO supervisor call). Finally, the AKEY & ATAB tables are passed to control data entry. This controls how the user enters data, tabs from one field to another & exits the routine. The screen may appear simple, even primitive, but there's a lot behind the scenes to consider.

***********************************************************************
*        BOX COMPONENTS (COORDINATES/FRAME)                           *
***********************************************************************
BXTAB    DS    0F
         DC    AL1(0,0,23,79)                BOX COORDINATES/FRAME
***********************************************************************
*        SCREEN DISPLAY COMPONENTS                                    *
***********************************************************************
SCTAB    DS    0F
         DC    AL1(0,0,4,8),A(SCR01)         SCREEN COORDINATES/MSG
         DC    AL1(0,0,6,8),A(SCR02)         SCREEN COORDINATES/MSG
         DC    AL1(0,0,8,8),A(SCR03)         SCREEN COORDINATES/MSG
         DC    AL1(0,0,10,8),A(SCR04)        SCREEN COORDINATES/MSG
*        DC    AL1(0,0,12,8),A(SCR05)        SCREEN COORDINATES/MSG
SCTABF1  DC    AL1(0,0,15,8),A(SCR99F1)      SCREEN COORDINATES/MSG
         DC    AL1(0,0,17,8),A(SCR99X)       SCREEN COORDINATES/MSG
         DC    XL1'FF'                       END OF TABLE
***********************************************************************
SCR01    DC    C'T D A G R A M 2   -   KEYBOARD INPUT$'
SCR02    DC    C' OPPONENT:',C'$'
SCR03    DC    C'   DEALER:',C'$'
SCR04    DC    C'   RESULT:   ',C'$'
SCR05    DC    CL60' ',C'$'
SCR99F1  DC    C'PRESS <F1> TO SELECT',C'$'
SCR99X   DC    C'PRESS <ESC> TO EXIT SCREEN',C'$'
***********************************************************************
*        ACCEPT DATA COMPONENTS - TABLE A                             *
***********************************************************************
AKEY     DC    AL1(@K#ESC,@K#RET,@K#ARWU,@K#ARWD,@K#TAB,@K#TABL,@K#F1)
AKEYX    DC    X'FF'
***********************************************************************
ATAB     DS    0F
         DC    A(AC1),AL2(L'AC1),AL1(6,19,@E#CHR,0,@BKWT,@WTBK)
         DC    A(AC2),AL2(L'AC2),AL1(8,19,@E#CHR,0,@BKWT,@WTBK)
ATABX    DC    XL1'FF'
***********************************************************************
AC1      DC    CL2' ',C'$'                   ACCEPT - OPPONENT
AC2      DC    CL50' ',C'$'                  ACCEPT - DEALER HAND
***********************************************************************

There's too much information to explain in a single post - especially when it comes to the internals of the routines contained in the Copybooks. I'll save these for another time...

ACSL AGRAM Card Game - PC/370 VERSION!

Previous Post: ACSL AGRAM Card Game Exercise - Just for fun

My last post was about my daughter's recent computer lab assignment. It looked like a fun exercise so I created two quick solutions - one in SQR and another in WinBatch. Fun, but not enough fun. I realized I had to create a version using PC/370 Assembler. PC/370 is an emulation package (developed in the 1980's by Donald Higgins) that enables MVS/370 (mainframe) Assembler programs to be assembled, linked & executed on a Windows PC. More information HERE.

I hadn't written a PC/370 Assembler program since the end of the last century. One reason being it no longer worked on later Windows operating systems. This year I discovered the freeware product DOSBOX which is a DOS-emulator. It allows older PC-based games & software to run on multiple platforms - including Windows 10. Now I can run my old PC/370 programs & create new ones.

Above: DOSBOX Session - Primed & ready to Assemble, Link & Execute my PC/370 AGRAM program.


MODULE: TDAGRAM.ALC

The Module TDAGRAM will read an input file (similar to the SQR version) & create formatted output to display the results. The full DOSBOX & PC/370 steps are below:

Z:\>MOUNT C C:\
Z:\>C:
C:\>CD PC370
C:\PC370>A370 TDAGRAM/LX
C:\PC370>L370 TDAGRAM/LX
C:\PC370>TDAGRAM

The first 3 steps MOUNT the C: drive & navigates to the PC370 directory.
Then the module TDAGRAM is assembled (A370), linked (L370) & executed.
(Assemble/Link only occur after a program change)

INPUT - C:\PC370\TDAGRAM.TXT

5D,2D,6H,9D,TD,6H
TC,AC,KC,QH,JS,TD
3D,4H,5C,6S,2D,7H
KS,TH,QC,7H,9H,3H
AC,AD,KH,JS,KS,QS
3H,2D,AC,9S,AH,QH,KH,AH,AS,AH,TD,3C,KC,2H,5H,6H,6S,9D,9D,9D,4H,KS
KH,2H,4C,5S,AH,KD
KH,2H,4C,5S,3H,KD

OUTPUT - C:\PC370\TDAGRAM.OUT

   OPPONENT: 5D
DEALER HAND: 2D,6H,9D,TD,6H
  SELECTION: 9D

   OPPONENT: TC
DEALER HAND: AC,KC,QH,JS,TD
  SELECTION: KC

   OPPONENT: 3D
DEALER HAND: 4H,5C,6S,2D,7H
  SELECTION: 2D

   OPPONENT: KS
DEALER HAND: TH,QC,7H,9H,3H
  SELECTION: 3H

   OPPONENT: AC
DEALER HAND: AD,KH,JS,KS,QS
  SELECTION: AD

   OPPONENT: 3H
DEALER HAND: 2D,AC,9S,AH,QH,KH,AH,AS,AH,TD,3C,KC,2H,5H,6H,6S,9D,9D,9D,4H,KS
  SELECTION: 4H

   OPPONENT: KH
DEALER HAND: 2H,4C,5S,AH,KD
  SELECTION: AH

   OPPONENT: KH
DEALER HAND: 2H,4C,5S,3H,KD
  SELECTION: 2H        

As the INPUT / OUTPUT reveal the process ended successfully with the proper cards selected for each hand.

Key Routine - Setting the Face Value

In the SQR & WinBatch versions I set the weighted value of each face (Ace, Jack, Queen, King, etc.) using a string that represents the "Order of Magnitude". I extracted the position using either the Instr() or StrIndex() functions. I'll do something similar in the PC/370 version.

***********************************************************************
*        SET FACE VALUE                      R4=CARD ENTRY            *
***********************************************************************
         DC    F'0'                          RETURN ADDRESS SAVE AREA
VALUE    EQU   *
         ST    6,*-4                         SAVE RETURN ADDRESS
*
         MVI   3(4),X'00'                    INITIALIZE VALUE
*
         LA    3,VALTAB                      LOAD TABLE ADDRESS
VALUE1   EQU   *
         CLI   0(3),X'FF'                    END OF TABLE?
         BE    VALUEX                        YES - EXIT ROUTINE
         CLC   0(1,3),0(4)                   CARD FACE MATCH???
         BE    VALUE2                        YES - EXIT LOOP
         LA    3,1(,3)                       BUMP TO NEXT ENTRY
         B     VALUE1                        TEST NEXT ENTRY
VALUE2   EQU   *
         S     3,=A(VALTAB-1)                SUBTRACT TABLE ADDRESS
         STCM  3,B'0001',3(4)                STORE BIT VALUE
VALUEX   EQU   *
         L     6,VALUE-4                     RESTORE LINK REGISTER
         BR    6                             BRANCH ON LINK REGISTER
VALTAB   DC    C'A23456789TJQK'              CARD VALUE TABLE
         DC    X'FF'                         END OF TABLE
***********************************************************************

I use register 3 to loop through each position of the VALTAB string until it finds the address of the "FACE" character. Register 4 contains a 4-byte template for the card I'm looking for  - 2 characters for the card (Face/Suit combination), 1 for the suit & the last for the face value (in hexadecimal). I could use the full address as a weighted value but that's cumbersome. By subtracting the starting address of the table (minus one) I'm left with the values 1 thru 13 - or X'01' thru X'0D'. That single hex value is transferred to my template using a STCM instruction (Store Characters Under Mask). The mask B'0001' is set to the last portion of bits in register 3 - then copied to the value bucket.

Card Selection Routine:

Assembler is very compact, cryptic & doesn't have indentation that may help visually. It's interesting comparing the logical constructs in PC/370 with the SQR & WinBatch versions.

***********************************************************************
*        SELECT CARD                                                  *
***********************************************************************
         DC    F'0'                          RETURN ADDRESS SAVE AREA
SELECT   EQU   *
         ST    6,*-4                         SAVE RETURN ADDRESS
*
         MVC   XXXDATA,DEALER                SELECT FIRST CARDS
*
         LA    4,DEALER+4                    LOAD NEXT DEALER ADDRESS
         USING DLRTAB,4                      USE DEALER TABLE DSECT
SELLOOP  EQU   *
         CLI   DLRVAL,X'00'                  END OF CARDS???
         BE    SELECTX                       YES - EXIT ROUTINE
*
         CLC   XXXSUIT,OPPSUIT               PRIOR SUIT MATCH?
         BE    SELSUIT                       YES - IGNORE OTHERS
         CLC   DLRVAL,XXXVAL                 DEALER LOWER VALUE?
         BL    SELMOVE                       YES - SELECT DEALER
         CLC   DLRSUIT,OPPSUIT               SUIT MATCH DETECTED?
         BE    SELMOVE                       YES - SELECT DEALER
         B     SELBUMP                       BUMP DEALER POINTER
SELSUIT  EQU   *
         CLC   XXXSUIT,DLRSUIT               MATCHING SUITS?
         BNE   SELBUMP                       NO  - BUMP DEALER
*
         CLC   XXXVAL,OPPVAL                 HI PRIOR VALUE?
         BNH   SELUNDER                      NO  - TRY UNDER
         CLC   DLRVAL,OPPVAL                 HI DEALER VALUE?
         BNH   SELBUMP                       NO  - BUMP DEALER
         CLC   DLRVAL,XXXVAL                 DEALER < PRIOR?
         BNL   SELBUMP                       NO  - BUMP DEALER
         B     SELMOVE                       MOVE DEALER ENTRY
SELUNDER EQU   *
         CLC   XXXVAL,DLRVAL                 PRIOR < DEALER??
         BNL   SELMOVE                       NO  - MOVE DEALER
         CLC   OPPVAL,DLRVAL                 OPPONENT LESS?
         BNL   SELBUMP                       NO  - BUMP DEALER
SELMOVE  EQU   *
         MVC   XXXDATA,DLRDATA               MOVE DEALER ENTRY
SELBUMP  EQU   *
         MVC   DLRDATA,=XL4'00'              CLEAR DEALER ENTRY
         LA    4,4(,4)                       BUMP DEALER POINTER
         B     SELLOOP                       TEST NEXT ENTRY
SELECTX  EQU   *
         L     6,SELECT-4                    RESTORE LINK REGISTER
         BR    6                             BRANCH ON LINK REGISTER
***********************************************************************

When a new card is selected it copies data from the DLRDATA field to the XXXDATA field (highlighted in yellow above). DLRDATA represents the current DEALER entry which consists of the card, suit & value. When all cards in the hand have been evaluated the XXXDATA field contains the selected card information.

Full Source Code - TDAGRAM.ALC

         TITLE 'TDAGRAM  - PC/370 4.2 // DELIA'
***********************************************************************
*                                                                     *
*        MODULE:  TDAGRAM.                                            *
*        AUTHOR:  TONY DELIA.                                         *
*          DATE:  11/10/2019.                                         *
*          DESC:  PC/370 AGRAM CARD GAME.                             *
*          NOTE:  PC/370 RELEASE 4.2                                  *
*                                                                     *
***********************************************************************
         EJECT
***********************************************************************
*        T  D  A  G  R  A  M        P  R  O  G  R  A  M               *
***********************************************************************
TDAGRAM  START 0                             START PROGRAM
         STM   14,12,12(13)                  SAVE REGISTERS
         LR    12,15                         LOAD PROGRAM ENTRY POINT
         USING TDAGRAM+0*4096,12             BASE REGISTER 1
         L     11,BASE2                      LOAD BASE REGISTER 2
         USING TDAGRAM+1*4096,11             TELL ASSEMBLER ABOUT BASE2
         ST    13,SAVE+4                     SAVE EXTERNAL SAVE ADDRESS
         LR    14,13                         XFER ADDRESS TO TEMP R14
         LA    13,SAVE                       LOAD INTERNAL SAVE ADDRESS
         ST    13,8(14)                      SAVE IN EXTERNAL SAVE AREA
         B     GO                            BRANCH TO PROCESSING RTN
***********************************************************************
RETURN   EQU   *                             TIME TO RETURN
         L     13,SAVE+4                     RESTORE REGISTER 13
         LM    14,12,12(13)                  RESTORE REMAINING REGS
         SR    15,15                         CLEAR RETURN CODE
         BR    14                            BRANCH TO CALLING PROGRAM
***********************************************************************
SAVE     DC    18F'0'                        S A V E   A R E A
***********************************************************************
BASE2    DC    A(TDAGRAM+1*4096)             BASE2 DISPLACEMENT
***********************************************************************
GO       EQU   *                             BEGIN PROCESSING ...
***********************************************************************
         EJECT
***********************************************************************
*        MAINLINE PROCEDURE                                           *
***********************************************************************
         PRINT NOGEN
*
         XFILI STDWKI                        OPEN INPUT  FILE
         XFILO STDWKO                        OPEN OUTPUT FILE
GETI     EQU   *
         XREAD IREC,256                      READ INPUT RECORD
         BNZ   EOFI                          EOF - EXIT ROUTINE
*
         BAL   6,PARSE                       PARSE RECORD
         BAL   6,SELECT                      SELECT CARD
         BAL   6,RESULT                      PRINT RESULT
*
         B     GETI                          READ NEXT RECORD
EOFI     EQU   *
         B     RETURN                        EXIT PROGRAM PLEASE
***********************************************************************
         EJECT
***********************************************************************
*        PARSE RECORD                                                 *
***********************************************************************
         DC    F'0'                          RETURN ADDRESS SAVE AREA
PARSE    EQU   *
         ST    6,*-4                         SAVE RETURN ADDRESS
*
         MVC   OPPCARD,IREC                  MOVE OPPONENT CARD
         MVC   OPPSUIT,OPPCARD+1             MOVE OPPONENT SUIT
         LA    4,OPPCARD                     LOAD XLATE ADDRESS
         BAL   6,VALUE                       MOVE OPPONENT VALUE
*
         LA    4,DEALER                      LOAD DEALER ADDRESS
         LA    5,IREC+3                      LOAD INPUT POINTER  
PARSE1   EQU   *
         CLI   0(5),X'FF'                    END OF TABLE??
         BE    PARSEX                        YES - EXIT LOOP
         MVC   0(2,4),0(5)                   MOVE DEALER CARD
         MVC   2(1,4),1(5)                   MOVE DEALER SUIT
         BAL   6,VALUE                       MOVE DEALER VALUE
         CLI   2(5),C','                     MORE DEALER CARDS?
         BNE   PARSEX                        NO  - EXIT LOOP
         LA    4,4(,4)                       BUMP DEALER POINTER
         LA    5,3(,5)                       BUMP INPUT POINTER
         B     PARSE1                        PROCESS NEXT ENTRY 
PARSEX   EQU   *
         L     6,PARSE-4                     RESTORE LINK REGISTER
         BR    6                             BRANCH ON LINK REGISTER
***********************************************************************
         EJECT
***********************************************************************
*        SET FACE VALUE                      R4=CARD ENTRY            *
***********************************************************************
         DC    F'0'                          RETURN ADDRESS SAVE AREA
VALUE    EQU   *
         ST    6,*-4                         SAVE RETURN ADDRESS
*
         MVI   3(4),X'00'                    INITIALIZE VALUE
*
         LA    3,VALTAB                      LOAD TABLE ADDRESS
VALUE1   EQU   *
         CLI   0(3),X'FF'                    END OF TABLE?
         BE    VALUEX                        YES - EXIT ROUTINE
         CLC   0(1,3),0(4)                   CARD FACE MATCH???
         BE    VALUE2                        YES - EXIT LOOP
         LA    3,1(,3)                       BUMP TO NEXT ENTRY
         B     VALUE1                        TEST NEXT ENTRY
VALUE2   EQU   *
         S     3,=A(VALTAB-1)                SUBTRACT TABLE ADDRESS
         STCM  3,B'0001',3(4)                STORE BIT VALUE
VALUEX   EQU   *
         L     6,VALUE-4                     RESTORE LINK REGISTER
         BR    6                             BRANCH ON LINK REGISTER
VALTAB   DC    C'A23456789TJQK'              CARD VALUE TABLE
         DC    X'FF'                         END OF TABLE
***********************************************************************
         EJECT
***********************************************************************
*        SELECT CARD                                                  *
***********************************************************************
         DC    F'0'                          RETURN ADDRESS SAVE AREA
SELECT   EQU   *
         ST    6,*-4                         SAVE RETURN ADDRESS
*
         MVC   XXXDATA,DEALER                SELECT FIRST CARDS
*
         LA    4,DEALER+4                    LOAD NEXT DEALER ADDRESS
         USING DLRTAB,4                      USE DEALER TABLE DSECT
SELLOOP  EQU   *
         CLI   DLRVAL,X'00'                  END OF CARDS???
         BE    SELECTX                       YES - EXIT ROUTINE
*
         CLC   XXXSUIT,OPPSUIT               PRIOR SUIT MATCH?
         BE    SELSUIT                       YES - IGNORE OTHERS
         CLC   DLRVAL,XXXVAL                 DEALER LOWER VALUE?
         BL    SELMOVE                       YES - SELECT DEALER
         CLC   DLRSUIT,OPPSUIT               SUIT MATCH DETECTED?
         BE    SELMOVE                       YES - SELECT DEALER
         B     SELBUMP                       BUMP DEALER POINTER
SELSUIT  EQU   *
         CLC   XXXSUIT,DLRSUIT               MATCHING SUITS?
         BNE   SELBUMP                       NO  - BUMP DEALER
*
         CLC   XXXVAL,OPPVAL                 HI PRIOR VALUE?
         BNH   SELUNDER                      NO  - TRY UNDER
         CLC   DLRVAL,OPPVAL                 HI DEALER VALUE?
         BNH   SELBUMP                       NO  - BUMP DEALER
         CLC   DLRVAL,XXXVAL                 DEALER < PRIOR?
         BNL   SELBUMP                       NO  - BUMP DEALER
         B     SELMOVE                       MOVE DEALER ENTRY
SELUNDER EQU   *
         CLC   XXXVAL,DLRVAL                 PRIOR < DEALER??
         BNL   SELMOVE                       NO  - MOVE DEALER
         CLC   OPPVAL,DLRVAL                 OPPONENT LESS?
         BNL   SELBUMP                       NO  - BUMP DEALER
SELMOVE  EQU   *
         MVC   XXXDATA,DLRDATA               MOVE DEALER ENTRY
SELBUMP  EQU   *
         MVC   DLRDATA,=XL4'00'              CLEAR DEALER ENTRY
         LA    4,4(,4)                       BUMP DEALER POINTER
         B     SELLOOP                       TEST NEXT ENTRY
SELECTX  EQU   *
         L     6,SELECT-4                    RESTORE LINK REGISTER
         BR    6                             BRANCH ON LINK REGISTER
***********************************************************************
         EJECT
***********************************************************************
*        RESULTS                                                      *
***********************************************************************
         DC    F'0'                          RETURN ADDRESS SAVE AREA
RESULT   EQU   *
         ST    6,*-4                         SAVE RETURN ADDRESS
*
         MVC   OPRT(13),LIT1                 MOVE LITERAL STRING
         MVC   OPRT+13(2),OPPCARD            MOVE OPPONENT CARD
         XPRNT OREC,100                      WRITE OUTPUT RECORD
         MVC   OPRT,OREC                     CLEAR OUTPUT LINE
*
         MVC   OPRT(13),LIT2                 MOVE LITERAL STRING
         MVC   OPRT+13(85),IREC+3            MOVE DEALER HAND
         XPRNT OREC,100                      WRITE OUTPUT RECORD
         MVC   OPRT,OREC                     CLEAR OUTPUT LINE
*
         MVC   OPRT(13),LIT3                 MOVE LITERAL STRING
         MVC   OPRT+13(2),XXXCARD            MOVE SELECTED CARD
         XPRNT OREC,100                      WRITE OUTPUT RECORD
         MVC   OPRT,OREC                     CLEAR OUTPUT LINE
*
         XPRNT OREC,100                      WRITE BLANK RECORD
RESULTX  EQU   *
         L     6,RESULT-4                    RESTORE LINK REGISTER
         BR    6 
***********************************************************************
*        WORKING STORAGE                                              *
***********************************************************************
         CNOP  0,4
DEALER   EQU   *                             DEALER CARDS
         DC    55XL4'00000000'               CARD(2)/SUIT(1)/VALUE(1)
DEALERX  EQU   *
         DC    XL1'FF'                       END OF TABLE
*
OPPDATA  DS    0CL4                          OPPONENT
OPPCARD  DC    CL2'OO'                       OPPONENT - CARD
OPPSUIT  DC    CL1'O'                        OPPONENT - SUIT
OPPVAL   DC    XL1'00'                       OPPONENT - VALUE
XXXDATA  DS    0CL4                          SELECT
XXXCARD  DC    CL2'XX'                       SELECT   - CARD
XXXSUIT  DC    CL1'X'                        SELECT   - SUIT
XXXVAL   DC    XL1'00'                       SELECT   - VALUE
*
LIT1     DC    CL13'   OPPONENT: '           RESULT LITERAL 1
LIT2     DC    CL13'DEALER HAND: '           RESULT LITERAL 2
LIT3     DC    CL13'  SELECTION: '           RESULT LITERAL 3
***********************************************************************
*        DATA CONTROL BLOCK SET UP                                    *
***********************************************************************
STDWKI   DC    CL64'C:\PC370\TDAGRAM.TXT'
STDWKO   DC    CL64'C:\PC370\TDAGRAM.OUT'
***********************************************************************
*        OUTPUT RECORD                                                *
***********************************************************************
OREC     DC    CL1' '                        OUTPUT RECORD
OPRT     DC    CL132' '                      OUTPUT RECORD LINE
***********************************************************************
*        INPUT  RECORD                                                *
***********************************************************************
IREC     DS    CL256                         INPUT RECORD
***********************************************************************
         LTORG                               LITERAL POOL
***********************************************************************
*        COPYBOOKS                                                    *
***********************************************************************
         COPY  CPY/TDSVC.CPY                 COPYBOOK - SUPERVISOR
***********************************************************************
*        DEALER TABLE DSECT                                           *
***********************************************************************
DLRTAB   DSECT
DLRDATA  DS    0XL4
DLRCARD  DS    CL2
DLRSUIT  DS    CL1
DLRVAL   DS    XL1
***********************************************************************
         END   TDAGRAM

Not much else to say except this was another fun exercise & I'm happy to get the PC/370 emulation package back up & running via DOSBOX. 

ACSL AGRAM Card Game Exercise - Just for fun

Something fun. My youngest daughter is a senior in high school & is taking a Computer Programming class. One of her exercises was based on a contest problem sponsored by the ACSL (American Computer Science League). The task is to create an algorithm for a simple card game.

I had a little free time so I quickly created a solution in 2 languages - SQR & WinBatch. My primary goal was to streamline the logic in such as way so it's easy to understand & follow. Parents weren't allowed to help so she was on her own... but I will definitely follow up with her.

***UPDATE*** - PC/370 Assembler Version Created! CLICK HERE

INSTRUCTIONS:

The instructions on the AGRAM game itself are vague - it doesn't provide an explanation on how to conduct and win a complete game. Rather it focuses on the logic within a single hand.


Here is the ACSL PDF version of the rules: CLICK HERE

The assumption is that ALL CARDS are VALID members of a 52 card deck. No error checking is incorporated or required. I also ignored the unnecessary restriction of 5 cards - the logic works for 1 through 51 cards - it's driven entirely by the number of dealer cards presented.

The SQR version follows the INPUT instructions with each hand represented by a comma delimited record in a file. (The WinBatch version will utilize a prompt).

INPUT:

5D,2D,6H,9D,TD,6H
TC,AC,KC,QH,JS,TD
3D,4H,5C,6S,2D,7H
KS,TH,QC,7H,9H,3H
AC,AD,KH,JS,KS,QS
3H,2D,AC,9S,AH,QH,KH,AH,AS,AH,TD,3C,KC,2H,5H,6H,6S,9D,9D,9D,4H,KS
KH,2H,4C,5S,AH,KD
KH,2H,4C,5S,3H,KD

SQR VERSION:

The program reads one record at a time with each one performing the Process_Cards routine (shown below).

The XXX variables represent the card chosen by the dealer - it will contain the final choice once all cards in the dealers hand have been evaluated.

The OPP variables are used to hold the Opponent's card. Simple enough.

The DLR variables are used to hold the latest card (evaluated one by one) in the Dealer's Hand.

I used my own custom Parsing functions TDF_PARSE_Put() & TDF_PARSE_Get() to extract the individual data elements from the record. Index 0 contains the Opponent Card while Index 1 goes up to (but not including) the #O_cols counter. So a 5 card dealer hand has indexes 1 thru 5.

The 2-character card must be broken down & weighted. The function CARD_Parse() is utilized for all cards & returns the suit (C=Clubs, D=Diamonds, H=Hearts, S=Spades) and a weighted value. In this case, the "single-digit" number cards equal themselves (2 thru 9) - an A (Ace) has a value of 1 - while T (Ten), J (Jack), Q (Queen) & K (King) have the values 10 thru 13.

!**********************************************************************
!*       Process Cards                                                *
!**********************************************************************

begin-procedure Process_Cards

let $XXX_card                           = 'XX'
let $XXX_suit                           = 'X'
let #XXX_val                            = 0

do TDF_PARSE_Put($rec, ',', '', #O_cols)

do TDF_PARSE_Get( 0, $OPP_card)

do CARD_Parse($OPP_card, $OPP_suit, #OPP_val)

show 'Opponent: ' $OPP_card ' . ' $OPP_suit ' . ' #OPP_val edit 999

let #idx                                = 1

while #idx                              < #O_cols

   do TDF_PARSE_Get(#idx, $DLR_card)

   do CARD_Parse($DLR_card, $DLR_suit, #DLR_val)

   show '  Dealer: ' $DLR_card ' . ' $DLR_suit ' . ' #DLR_val edit 999

   !   Always Select the First Card (Skip Comparisons)
   !   ===============================================
   if  #idx                             = 1
       let $XXX_card                    = $DLR_card
       let $XXX_suit                    = $DLR_suit
       let #XXX_val                     = #DLR_val

   else

       !   No Suit Match Yet - If Lower Value OR Suit Select Card
       !   ======================================================
       if  $XXX_suit                   <> $OPP_suit
           if  #DLR_val                 < #XXX_val
           or  $DLR_suit                = $OPP_suit
               let $XXX_card            = $DLR_card
               let $XXX_suit            = $DLR_suit
               let #XXX_val             = #DLR_val
           end-if

       !   Same Suit - Ignore All other Suits from Dealer
       !   ==============================================
       else
           if  $XXX_suit                = $DLR_suit

               !   OVER Opponent Value - Select CARD if also over but < prior pick
               !   ===============================================================
               if  #XXX_val             > #OPP_val
                   if  #DLR_val         > #OPP_val
                   and #DLR_val         < #XXX_val
                       let $XXX_card    = $DLR_card
                       let $XXX_suit    = $DLR_suit
                       let #XXX_val     = #DLR_val
                   end-if

               !   UNDER Opponent Value - Select CARD if OVER Opponent or < prior pick
               !   ===================================================================
               else
                   if  #XXX_val         < #DLR_val
                       if #OPP_val      < #DLR_val
                          let $XXX_card = $DLR_card
                          let $XXX_suit = $DLR_suit
                          let #XXX_val  = #DLR_val
                       end-if
                   else
                       let $XXX_card    = $DLR_card
                       let $XXX_suit    = $DLR_suit
                       let #XXX_val     = #DLR_val
                   end-if
               end-if

           end-if

       end-if

   end-if

   let #idx                             = #idx + 1

end-while

show ' '
show 'Results: ' $rec ' ==> ' $XXX_card
show ' '

end-procedure

!**********************************************************************

The CARD_Parse() routine does NOT use hard-coded evaluate, switch or case constructs - or worse yet a series of convoluted If-Then-Else statements. I control the weighted values using a string of face characters represented by the order of magnitude. If I want a character to be high I place it at the end - any character - it could be a 7 if I like - who cares. The INSTR function returns the position in the string and uses that for the weighted value. Zero complexity.

!**********************************************************************
!*       CARD Parse                                                   *
!**********************************************************************

begin-procedure CARD_Parse($I_card, :$O_suit, :#O_val)

let $X_face = substr($I_card, 1, 1)
let $O_suit = substr($I_card, 2, 1)
let #O_val  = instr('A23456789TJQK', $X_face, 1) 

end-procedure

!**********************************************************************

Results (Snipped from LOG File):

Results: 5D,2D,6H,9D,TD,6H ==> 9D
Results: TC,AC,KC,QH,JS,TD ==> KC
Results: 3D,4H,5C,6S,2D,7H ==> 2D
Results: KS,TH,QC,7H,9H,3H ==> 3H
Results: AC,AD,KH,JS,KS,QS ==> AD
Results: 3H,2D,AC,9S,AH,QH,KH,AH,AS,AH,TD,3C,KC,2H,5H,6H,6S,9D,9D,9D,4H,KS ==> 4H
Results: KH,2H,4C,5S,AH,KD ==> AH
Results: KH,2H,4C,5S,3H,KD ==> 2H

WINBATCH VERSION:

For WinBatch I created a dialog panel to enter the opponent's card along with a comma delimited string of dealer cards. When the OK button is pressed the proper dealer card is selected & displayed in RED.

I'll show the Sample Results first this time followed by the routine.

The dialog has the GUI variables eOpponent & eCards to hold the input (as opposed to the file used in the SQR version). The GUI variable vResult will hold the result. In general the logic is identical to the SQR version  - the only difference being syntax/functions between the two languages. For example, StrIndex() is used to weight the cards instead of the Instr() function - same result.

;**********************************************************************
;*      Process Cards                                                 *
;**********************************************************************

:Process_Cards

DLR_hand                            = eCards
OPP_card                            = eOpponent

OPP_xlat                            = StrSub(OPP_card, 1, 1)
OPP_suit                            = StrSub(OPP_card, 2, 1)
OPP_val                             = StrIndex('A23456789TJQK', OPP_xlat, 1, @FWDSCAN)

XXX_card                            = 'XX'
XXX_suit                            = 'X'
XXX_val                             = 0

count                               = ItemCountCSV(DLR_hand, 0,",")

For x                               = 1 to count

    DLR_card                        = ItemExtractCSV(x, DLR_hand, 0, ",")
    DLR_xlat                        = StrSub(DLR_card, 1, 1)
    DLR_suit                        = StrSub(DLR_card, 2, 1)
    DLR_val                         = StrIndex('A23456789TJQK', DLR_xlat, 1, @FWDSCAN)

   ;   Always Select the First Card (Skip Comparisons)
   ;   ===============================================
   if  x                           == 1
       XXX_card                     = DLR_card
       XXX_suit                     = DLR_suit
       XXX_val                      = DLR_val

   else

       ;   No Suit Match Yet - If Lower Value OR Suit Select Card
       ;   ======================================================
       if  XXX_suit                <> OPP_suit
           if  DLR_val              < XXX_val   ||  DLR_suit    == OPP_suit
               XXX_card             = DLR_card
               XXX_suit             = DLR_suit
               XXX_val              = DLR_val
           endif

       ;   Same Suit - Ignore All other Suits from Dealer
       ;   ==============================================
       else
           if  XXX_suit            == DLR_suit

               ;   OVER Opponent Value - Select CARD if also over but < prior pick
               ;   ===============================================================
               if  XXX_val          > OPP_val
                   if  DLR_val      > OPP_val   &&  DLR_val      < XXX_val
                       XXX_card     = DLR_card
                       XXX_suit     = DLR_suit
                       XXX_val      = DLR_val
                   endif

               ;   UNDER Opponent Value - Select CARD if OVER Opponent or < prior pick
               ;   ===================================================================
               else
                   if  XXX_val      < DLR_val
                       if OPP_val   < DLR_val
                          XXX_card  = DLR_card
                          XXX_suit  = DLR_suit
                          XXX_val   = DLR_val
                       endif
                   else
                       XXX_card     = DLR_card
                       XXX_suit     = DLR_suit
                       XXX_val      = DLR_val
                   endif
               endif

           endif

       endif

   endif

Next

vResult                             = XXX_card

Return

;**********************************************************************

I'm looking forward to the next exercise my daughter brings home...