***************************************************************** ** COMPANY NAME: ***************************************************************** ** Application......: TETRIS FOR THE AS/400 ** ** Module Name......: ** Program Name.....: V2 ** Program Description: TETRIS CLONE GAME FOR AS/400 ** ** Documentation....: ** Called By........: ** Sequence.........: ** Programs Called..: ** ** Create Options...: *USRPRF(USER) ** Object Owner.....: QPGMR ** CREATED By.......: ** Creation Date....: ** ** ***************************************************************** * * INPUT FILES: V2PF * * UPDATE FILES: * ***************************************************************** * * PARAMETERS * ------------------------------------------------------------ * * PARAMETERS PASSED TO THIS PROGRAM: * * NAME DESCRIPTION * ---------- ----------------------------------------------- * NONE * ***************************************************************** * * PROGRAMS CALLED * ------------------------------------------------------------ * NO PROGRAMS CALLED * ***************************************************************** * * INDICATOR SUMMARY * ------------------------------------------------------------ * *INXX FUNCTION * ------ ----------------------------------------------------- * *IN01 File operations * *IN20 New Item * *IN21 Delete line * *IN22 Redraw * *IN23 Break * *IN30 Find in array * *IN50 Workstn operations * *IN51 Workstn operations * *IN52 Workstn operations * *IN53 Workstn operations * *INLR END OF FILE ***************************************************************** * MODIFICATION LOG: * *===============================================================* *##|WHO |WHEN |WHAT & (CSR#) * *===============================================================* *01|RKNECHTEL |07/06/1998|CONVERTED TO RPG IV. CLEANED UP CODE * * | | | * *---------------------------------------------------------------* /TITLE --- FILES --- *------------------------------------------------------ *====================================================== /TITLE --- COMMENTS *------------------------------------------------------ * Object - a piece of 'O'-blocks * Fields: * #L - first row * #K - last row * #I - first pos. * #J - last pos. * Methods: * SB3100 - Drop Enter * SB3101 - Down Auto * SB3200 - Left Max F5 * SB3201 - Left F6 * SB3300 - Right Max F8 * SB3301 - Right F7 * SB3400 - Rotate F9 * SB3102 - Curr test Service * SB3103 - Curr curr Service * SB3500 - Stop Auto * SB3600 - Create Auto * SB3601 - Create test Service * SB3602 - Create curr Service *------------------------------------------------------ * Object - a glass * Fields: * #M - start row to del. * #N - end row to del. * #O - current row to del. * #SCR - current score * #SCRR - record score * #NAMR - -"- name of owner * #TIMR - -"- time from * Methods: * SB2000 - Delete rows Auto * SB2001 - Delete row Service * SB2100 - Redraw Auto * SB2200 - Set pos. Service (#A #B) * SB2201 - Get char Service (#A #B #CC) * SB2202 - Put char Service (#A #B #CC) * SB1001 - Init F12, Auto * SB1100 - Reset F12, Auto * SB1200 - Get time Auto * SB1201 - Put time Auto * SB1300 - Get record Auto * SB1301 - Put record Auto *------------------------------------------------------ * System functions: *------------------------------------------------------ * Object - a work glass * Methods: * SB4200 - RSet pos. Service (#Q #E) * SB4201 - RGet char Service (#Q #E #CR) * SB4202 - RPut char Service (#Q #E #CR) * SB4300 - RPut all Service (#S #T) * SB4301 - RRestore all Service (#S #T) *------------------------------------------------------ * Object - a image array * Methods: * SB5200 - FSet pos. Service (#Q #E) * SB5201 - FGet char Service (#Q #E #CF) * SB5202 - FPut char Service (#Q #E #CF) * SB5800 - VSet pos. Service (#E 11-#Q) * SB5801 - VGet char Service (#E 11-#Q #CV) * SB5802 - VPut char Service (#E 11-#Q #CV) * SB5100 - FRotate Service * SB5300 - FAdd Service * SB5400 - FXor Service * SB5500 - FRotated Service * SB5900 - FTest Service * SB5099 - FHide Service *------------------------------------------------------ * SB9999 - Exit F3 *------------------------------------------------------ * FSPECS ************************************************* FV2PF UF A E DISK FV2DF CF E WORKSTN F MAXDEV(*FILE) F INFDS(F$$) *====================================================== /TITLE --- EXTENSIONS --- *------------------------------------------------------ **************************************************** * A (30x18) - main glass on the screen (visible) * **************************************************** D #A1 S 1 DIM(30) :from :curr D #A2 S 1 DIM(30) :to D #AO S 30 DIM(18) :all rows * **************************************************** * B (4x4) - glass where is built new look after * * action with the piece (work glass) * **************************************************** D #B1 S 1 DIM(4) :R:curr D #BO S 4 DIM(4) :R:all rows * **************************************************** * C (4x4) - glass where is stored image * * of current piece after creating * **************************************************** D #C1 S 1 DIM(4) :F:curr D #CO S 4 DIM(4) :F:all rows * **************************************************** * V (4x4) - glass where is stored current piece * * after rotate (temporary) * **************************************************** D #V1 S 1 DIM(4) :V:curr D #VO S 4 DIM(4) :V:all rows * **************************************************** * T (4x4) - glass where is stored piece * * for testing (temporary) * **************************************************** D #T1 S 1 DIM(4) :T:curr D #TO S 4 DIM(4) :T:all rows **************************************************** * F (18x15) - array for initialize piece * * while creating ( 17,18 pos - sizes) * **************************************************** D #F1 S 1 DIM(18) :F:curr D #FO S 18 DIM(15) CTDATA PERRCD(1) :F:all rows * **************************************************** * zeros and 1's arrays of various lengths * **************************************************** D #Z2 S 1 DIM(20) CTDATA PERRCD(20) :zeros D #O2 S 1 DIM(20) CTDATA PERRCD(20) :1's D #O6 S 1 DIM(6) CTDATA PERRCD(6) :1's *====================================================== /TITLE --- DATA --- *------------------------------------------------------ D DS D #TALL 1 14 D #TTHH 1 2 D #TTMM 3 4 D #TTSS 5 6 D #TDMM 7 8 D #TDDD 9 10 D #TDYY 11 14 D DS INZ D #OALL 1 21 INZ D #OTHH 1 2 INZ D #S1 3 3 INZ(':') D #OTMM 4 5 INZ D #S2 6 6 INZ(':') D #OTSS 7 8 INZ D #S3 9 11 INZ(' ') D #ODMM 12 13 INZ D #S4 14 14 INZ('.') D #ODDD 15 16 INZ D #S5 17 17 INZ('.') D #ODYY 18 21 INZ *------------------------------------------------------ D F$$ DS D F#KEY 369 369 *------------------------------------------------------ D @PSDS SDS D MSGPQ *PROC *------------------------------------------------------ D C#F03 C CONST(X'33') D C#F05 C CONST(X'35') D C#F06 C CONST(X'36') D C#F07 C CONST(X'37') D C#F08 C CONST(X'38') D C#F09 C CONST(X'39') D C#F12 C CONST(X'3C') D C#ENTR C CONST(X'F1') *------------------------------------------------------ D C#CHR C CONST('O') D C#DCH C CONST('OO') D C#1 C CONST(1) D C#2 C CONST(30) D C#3 C CONST(15) D C#10 C CONST(4) D C#9 C CONST(3) D C#R1 C CONST(1) D C#R2 C CONST(18) D C#SR C CONST(1) D C#SC C CONST(5) *------------------------------------------------------ * MISC VARIABLES D#SCR S 5 0 D#SCRR S 5 0 D#USED S 5 0 D#NAMR S 20 D#TIMR S 21 D#I S 2 0 D#J S 2 0 D#K S 2 0 D#L S 2 0 D#M S 2 0 D#N S 2 0 D#O S 2 0 *====================================================== /TITLE --- CALCULATIONS --- *------------------------------------------------------ *------------------- MAIN ROUTINE --------------------- * * #D - VARIABLE FOR INDEX *IN ARRAY *------------------------------------------------------ C *DTAARA DEFINE #D 2 0 C LBRST TAG C EXSR SB1001 init C LBINV TAG C EXSR SB1200 get time C EXSR SB1201 put time C 20 EXSR SB3600 create C 59 ADD #L #D 2 0 1st row ovr C MOVEA #O6 *IN(#D) 6 rows ovr C EXSR SB3101 down C 22 EXSR SB2100 redraw C EVAL *IN50 = *ON INVITE C WRITE V200 51 C MOVEA #Z2 *IN(59) noovrdta all C LBRED TAG C READ V2DF 5253 C 52 GOTO LBINV err=>cycle C C#F03 CASEQ F#KEY SB9999 exit C C#F12 CASEQ F#KEY SB1100 reset C C#F05 CASEQ F#KEY SB3200 left-max C C#F06 CASEQ F#KEY SB3201 left C C#F07 CASEQ F#KEY SB3301 right C C#F08 CASEQ F#KEY SB3300 right-max C C#F09 CASEQ F#KEY SB3400 rotate C C#ENTR CASEQ F#KEY SB3100 drop C ENDCS C GOTO LBINV inv again C EXSR SB9999 exit *====================================================== /TITLE --- SB1200 --- GET TIME C SB1200 BEGSR C TIME #TIME 14 0 C MOVEL(P) #TIME #TALL C EVAL #OTHH = #TTHH C EVAL #OTMM = #TTMM C EVAL #OTSS = #TTSS C EVAL #ODDD = #TDDD C EVAL #ODMM = #TDMM C EVAL #ODYY = #TDYY C ENDSR *====================================================== /TITLE --- SB1201 --- PUT TIME C SB1201 BEGSR C MOVEL #OALL $$OALL C ENDSR *====================================================== /TITLE --- SB1100 --- RESET C SB1100 BEGSR C EXSR SB1300 get record C IF #SCRR < #SCR C EXSR SB1301 put record C ENDIF C GOTO LBRST C ENDSR *====================================================== /TITLE --- SB1001 --- INIT C SB1001 BEGSR C EVAL *IN20 = *ON CREATE C EVAL *IN22 = *ON REDRAW C EVAL *IN21 = *OFF DEL.LINE C EVAL *IN23 = *OFF BREAK C EVAL #SCR = 0 curr.score C EVAL #SCRR = 0 score rec C EVAL #USED = 0 used flag C EVAL #NAMR = *BLANKS name rec C EVAL #TIMR = *BLANKS time rec C EVAL #I = 0 :x0 C EVAL #J = 0 :x1 C EVAL #K = 0 :y0 C EVAL #L = 0 :y1 C EVAL #M = 0 :row top C EVAL #N = 0 :row bottom C EVAL #O = 0 :row current C EVAL #A1 = *BLANKS C EVAL #A2 = *BLANKS C EVAL #A0 = *BLANKS C EVAL #B1 = *BLANKS C EVAL #BO = *BLANKS C EVAL #C1 = *BLANKS C EVAL #CO = *BLANKS C EVAL #V1 = *BLANKS C EVAL #VO = *BLANKS C EVAL #T1 = *BLANKS C EVAL #TO = *BLANKS C EXSR SB1300 get record C MOVEA #O2 *IN(59) ovrdta all C ENDSR *====================================================== /TITLE --- SB2100 --- REDRAW C SB2100 BEGSR C MOVEA #AO(1) $$O01 C MOVEA #AO(2) $$O02 C MOVEA #AO(3) $$O03 C MOVEA #AO(4) $$O04 C MOVEA #AO(5) $$O05 C MOVEA #AO(6) $$O06 C MOVEA #AO(7) $$O07 C MOVEA #AO(8) $$O08 C MOVEA #AO(9) $$O09 C MOVEA #AO(10) $$O10 C MOVEA #AO(11) $$O11 C MOVEA #AO(12) $$O12 C MOVEA #AO(13) $$O13 C MOVEA #AO(14) $$O14 C MOVEA #AO(15) $$O15 C MOVEA #AO(16) $$O16 C MOVEA #AO(17) $$O17 C MOVEA #AO(18) $$O18 C Z-ADD #SCR $$OSCR C Z-ADD #SCRR $$RECR C MOVEL(P) #NAMR $$NAME C MOVEL(P) #TIMR $$FROM C SETOFF 22 redraw C ENDSR *====================================================== /TITLE --- SB1300 --- GET RECORD C SB1300 BEGSR C 1 SETLL V2R C READ(N) V2R 01 C *IN01 IFEQ *OFF C Z-ADD V2SCR #SCRR C Z-ADD V2USED #USED C MOVEL(P) V2NAME #NAMR C MOVEL(P) V2DATE #TIMR C ELSE C Z-ADD 0 #SCRR C Z-ADD 0 #USED C EVAL #NAMR = *BLANKS C EVAL #TIMR = *BLANKS C ENDIF C EVAL *IN59 = *ON ovrdta recor C ENDSR *====================================================== /TITLE --- SB1301 --- PUT RECORD C SB1301 BEGSR C EXFMT VREC input name C 1 SETLL V2R C READ(N) V2R 01 C IF *IN01 = *OFF !EOF C IF #USED = V2USED AND #SCR > V2SCR !locked C 1 SETLL V2R C READ V2R 01 C EVAL V2USED = V2USED + 1 C UPDATE V2R C 1 SETLL V2R C READ V2R 01 C Z-ADD #SCR V2SCR C MOVEL $$INAM V2NAME C EXSR SB1200 get time C MOVEL #OALL V2DATE C UPDATE V2R C UNLOCK V2PF C ELSE C EXFMT VLAT sorry, late C ENDIF C ELSE empty file C EVAL V2SCR = #SCR C MOVEL $$INAM V2NAME C EXSR SB1200 get time C MOVEL #OALL V2DATE C EVAL V2USED = 0 C WRITE V2R C UNLOCK V2PF C ENDIF C ENDSR *====================================================== /TITLE --- SB2000 --- DEL.ROWS * #Z - LOCAL VARIABLE (ROWS TO DELETE) C SB2000 BEGSR C *LIKE DEFINE #D #Z C EVAL #Z = (#N - #M) C EVAL #Z = #Z + 1 C EVAL #O = #N C 1 DO #Z C EXSR SB2001 del.row C IF *IN23 = *ON !deleted C EVAL #O = #O - 1 C ENDIF C ENDDO C 1 DO #N #Z C EVAL #D = #Z + 60 C EVAL *IN(#D) = *ON ovrdta row D C ENDDO C EVAL *IN20 = *ON create C EVAL *IN22 = *ON redraw C EVAL *IN21 = *OFF del.row C ENDSR *====================================================== /TITLE --- SB2001 --- DEL.ROW *------------------------------------------------------ * #X,#Y,#W,#V - LOCAL VARIABLES *------------------------------------------------------ C SB2001 BEGSR C *LIKE DEFINE #D #Y C *LIKE DEFINE #D #X C *LIKE DEFINE #D #W C *LIKE DEFINE #D #V C EVAL *IN23 = *OFF !break C MOVEA #AO(#O) #A1 C EVAL *IN30 = *OFF !found C ' ' LOOKUP #A1 30 C IF *IN30 = *ON ' ' found C EVAL *IN23 = *ON break C ELSE ' '!found C EVAL #Y = #O - 1 how many C 1 DO #Y #X C EVAL #V = #O - #X :from C EVAL #W = #V + 1 :to C MOVEA #AO(#V) #A1 C MOVEA #A1 #AO(#W) C ENDDO C MOVEA *BLANKS #A1 C MOVEA #A1 #AO(1) C EVAL #SCR = #SCR +1 curr.score C EVAL *IN60 = *ON ovrdta score C ENDIF C ENDSR *====================================================== /TITLE --- SB2200 --- SET POS *------------------------------------------------------ * #A - ROW 1..18 * #B - POS 1..15 * #C - POS 1..30 * #CC - CHAR 'OO'³' ' *------------------------------------------------------ C SB2200 BEGSR C *LIKE DEFINE #D #A C *LIKE DEFINE #D #B C *LIKE DEFINE #D #C C *DTAARA DEFINE #CC 2 C MOVEA #AO(#A) #A1 C EVAL #C = #B * 2 C EVAL #C = #C -1 C ENDSR *====================================================== /TITLE --- SB2201 --- GET CHAR C SB2201 BEGSR C EXSR SB2200 Set pos C MOVEA #A1(#C) #CC C ENDSR *====================================================== /TITLE --- SB2202 --- PUT CHAR C SB2202 BEGSR C EXSR SB2200 Set pos C MOVEA #CC #A1(#C) C MOVEA #A1 #AO(#A) C ENDSR *====================================================== /TITLE --- SB3100 --- DROP *------------------------------------------------------ * #F - START ROW FROM WICH ITEM WAS DROPED * #G - CURR. ROW TROUGH WICH ITEM WAS FLOWN *------------------------------------------------------ C SB3100 BEGSR C *LIKE DEFINE #D #F C *LIKE DEFINE #D #G C EVAL #F = #L start row C EVAL *IN23 = *OFF !break C DOU *IN23 = *ON C EXSR SB3101 down C ENDDO C EVAL *IN23 = *OFF !break C #F DO #K #G all flown ro C EVAL #D = #G + 60 C EVAL *IN(#D) = *ON ovrdta row D C ENDDO C ENDSR *====================================================== /TITLE --- SB3101 --- DOWN C SB3101 BEGSR C EVAL *IN23 = *OFF !break C IF #K >= C#R2 C EVAL *IN23 = *ON break C ELSE C EVAL #S = #L + 1 ++row C EVAL #T = #I col C EVAL #U = 0 no rotate C EXSR SB3102 curr test C ENDIF C IF *IN23 = *OFF Ok! C EXSR SB3103 curr curr C EVAL *IN22 = *ON redraw C EVAL #L = #L + 1 C EVAL #K = #K + 1 C ELSE C EVAL #M = #L C EVAL #N = #K C EXSR SB2000 del.rows C ENDIF C ENDSR *====================================================== /TITLE --- SB3200 --- LEFT-MAX C SB3200 BEGSR C SETOFF 23 !break C DOU *IN23 = *ON C EXSR SB3201 left C ENDDO C ENDSR *====================================================== /TITLE --- SB3201 --- LEFT C SB3201 BEGSR C EVAL *IN23 = *OFF !break C IF #I <= C#1 first row C EVAL *IN23 = *ON break C ELSE C EVAL #S = #L row C EVAL #T = #I - 1 --col C EVAL #U = 0 no rotate C EXSR SB3102 curr test C ENDIF C IF *IN23 = *OFF Ok! C EXSR SB3103 curr curr C EVAL #I = #I - 1 C EVAL #J = #J - 1 C EVAL *IN22 = *ON redraw C ENDIF C ENDSR *====================================================== /TITLE --- SB3300 --- RIGHT-MAX C SB3300 BEGSR C EVAL *IN23 = *OFF !break C DOU *IN23 = *ON C EXSR SB3301 right C ENDDO C ENDSR *====================================================== /TITLE --- SB3301 --- RIGHT C SB3301 BEGSR C EVAL *IN23 = *OFF !break C IF #J >= C#3 last row C EVAL *IN23 = *ON break C ELSE C EVAL #S = #L row C EVAL #T = #I + 1 ++col C EVAL #U = 0 no rotate C EXSR SB3102 curr test C ENDIF C IF *IN23 = *OFF Ok! C EXSR SB3103 curr curr C EVAL #I = #I + 1 C EVAL #J = #J + 1 C EVAL *IN22 = *ON redraw C ENDIF C ENDSR *====================================================== /TITLE --- SB3400 --- ROTATE *------------------------------------------------------ * #XR,#YR - LOCAL VARIABLE *------------------------------------------------------ C SB3400 BEGSR C *LIKE DEFINE #D #XR C *LIKE DEFINE #D #YR C EVAL *IN23 = *OFF !break C EVAL #XR = #J - #I C EVAL #XR = #XR + #L C IF #XR > C#R2 C EVAL *IN23 = *ON break C ENDIF C EVAL #XR = #K - #L C EVAL #XR = #XR + #I C IF #XR > C#3 C EVAL *IN23 = *ON break C ENDIF C IF *IN23 = *OFF C EVAL #S = #L row C EVAL #T = #I col C EVAL #U = 1 rotate C EXSR SB3102 curr test C ENDIF C IF *IN23 = *OFF Ok! C EXSR SB3103 curr curr C EXSR SB5500 frotated C EVAL #XR = #J - #I C EVAL #YR = #K - #L C EVAL #J = #I + #YR C EVAL #K = #L + #XR C EVAL *IN22 = *ON redraw C ENDIF C ENDSR *====================================================== /TITLE --- SB3102 --- CURR TEST C SB3102 BEGSR C EXSR SB4300 rput all C EXSR SB5400 fxor C IF #U = 1 C EXSR SB5100 frotate C MOVEA #VO #TO rot->tmp C ELSE C MOVEA #CO #TO img->tmp C ENDIF C EXSR SB5900 ftest C ENDSR *====================================================== /TITLE --- SB3103 --- CURR CURR C SB3103 BEGSR C EXSR SB5099 fhide item C EXSR SB4300 rput all C EXSR SB5300 fadd C EXSR SB4301 rrestore all C ENDSR *====================================================== /TITLE --- SB3600 --- CREATE *------------------------------------------------------ * #RR - RANDOM *------------------------------------------------------ * max size: 4x4 (C#10xC#10) *------------------------------------------------------ C SB3600 BEGSR C *DTAARA DEFINE #RR 2 0 C EXSR SB1200 get time C MOVE(P) #TTSS #RR C #RR DIV 15 #RR C MVR #RR 0...14 C EVAL #RR = #RR + 1 1...15 C MOVEA #FO(#RR) #F1 C MOVEA #F1 #TO C EVAL #L = C#SR C MOVE(P) #F1(17) #K C EVAL #K = #K + #L C EVAL #K = #K - 1 C EVAL #I = C#SC C MOVE(P) #F1(18) #J C EVAL #J = #J + #I C EVAL #J = #J - 1 C EVAL #S = C#SR C EVAL #T = C#SC C EVAL #U = 0 C EVAL *IN23 = *OFF !break C EXSR SB3601 create test C IF *IN23 = *ON cannot crt C EXSR SB1100 reset C ELSE C EXSR SB3602 create curr C ENDIF C EVAL *IN22 = *ON redraw C EVAL *IN20 = *OFF create C ENDSR *====================================================== /TITLE --- SB3601 --- CREATE TEST C SB3601 BEGSR C EXSR SB4300 rput all C EXSR SB5900 ftest C ENDSR *====================================================== /TITLE --- SB3602 --- CREATE CURR C SB3602 BEGSR C EXSR SB4300 rput all C EXSR SB5300 fadd C EXSR SB4301 rrestore all C MOVEA #TO #CO C ENDSR *====================================================== /TITLE --- SB4300 --- RPUT ALL *------------------------------------------------------ * #XP,#YP - LOCAL VARIABLES *------------------------------------------------------ * #S - START ROW ( 0³1 + #L) * #T - START POS (-1³0³1 + #I) * #U - ROTATE FLAG ( 0³1 ) *------------------------------------------------------ C SB4300 BEGSR C *LIKE DEFINE #D #T C *LIKE DEFINE #D #S C *LIKE DEFINE #D #U C *LIKE DEFINE #D #XP C *LIKE DEFINE #D #YP C MOVEA *BLANKS #BO C MOVEA *BLANKS #B1 C 0 DO C#9 #YP C EVAL #Q = #YP + 1 dst row C EVAL #A = #YP + #S src row C IF #A > C#R2 C ITER C ENDIF C 0 DO C#9 #XP C EVAL #B = #T + #XP src pos C IF #B > C#3 C ITER C ENDIF C EXSR SB2201 get char C MOVE #CC #CR C EVAL #E = #XP + 1 dst pos C EXSR SB4202 rput char C ENDDO C ENDDO C ENDSR *====================================================== /TITLE --- SB4301 --- RRESTORE ALL *------------------------------------------------------ * #XP,#YP - LOCAL VARIABLES (SHARED WITH RPUT ALL) *------------------------------------------------------ C SB4301 BEGSR C 0 DO C#9 #YP C EVAL #Q = #YP + 1 src row C 0 DO C#9 #XP C EVAL #E = #XP + 1 src pos C EXSR SB4201 rget char C IF C#CHR = #CR C EVAL #CC = C#DCH C ELSE C EVAL #CC = ' ' C ENDIF C EVAL #A = #S + #YP dst row C EVAL #B = #T + #XP dst pos C IF #A < C#R2 AND #B <= C#3 C EXSR SB2202 put char C ENDIF C ENDDO C ENDDO C ENDSR *====================================================== /TITLE --- SB5300 --- FADD ITEM *------------------------------------------------------ * #XP,#YP - LOCAL VARIABLES (SHARED WITH RPUT ALL) *------------------------------------------------------ C SB5300 BEGSR C 1 DO C#10 #XP rows C EVAL #Q = #XP dst row C MOVEA #TO(#Q) #T1 src row C 1 DO C#10 #YP cols C EVAL #E = #YP dst pos C EVAL #CR = #T1(#E) src pos red C IF #CR = C#CHR C EXSR SB4202 rput char C ENDIF C ENDDO C ENDDO C ENDSR *====================================================== /TITLE --- SB5400 --- FXOR ITEM *------------------------------------------------------ * #XP,#YP - LOCAL VARIABLES (SHARED WITH RPUT ALL) * #ZP - LOCAL VARIABLE *------------------------------------------------------ C SB5400 BEGSR C *LIKE DEFINE #D #ZP C 1 DO C#10 #XP rows C 1 DO C#10 #YP cols C EVAL #ZP = #S - #L delta row C EVAL #Q = #XP + #ZP src row C EVAL #ZP = #T - #I delta pos C EVAL #E = #YP + #ZP src pos *C IF #Q <= C#10 AND #Q >= 1 AND #E <= C#10 C #Q IFLE C#10 C #Q ANDGE 1 C #E ANDLE C#10 C #E ANGE 1 C EXSR SB5201 fget char C ELSE C EVAL #CF = ' ' C ENDIF C IF C#CHR = #CF C EVAL #CR = ' ' C EVAL #Q = #XP dst row C EVAL #E = #YP dst row C EXSR SB4202 rput char C ENDIF C ENDDO C ENDDO C ENDSR *====================================================== /TITLE --- SB5100 --- FROTATE ITEM C SB5100 BEGSR C MOVEA *BLANKS #VO C MOVEA *BLANKS #V1 C 1 DO C#10 #Q rows C 1 DO C#10 #E cols C EXSR SB5201 fget char C IF #CF = C#CHR range Ok! C EVAL #CV = #CF C EXSR SB5802 vput char C ENDIF C ENDDO C ENDDO C ENDSR *====================================================== /TITLE --- SB5500 --- FROTATED ITEM C SB5500 BEGSR C MOVEA #VO #CO C ENDSR *====================================================== /TITLE --- SB5900 --- FTEST ITEM *------------------------------------------------------ * #XP,#YP - LOCAL VARIABLES (SHARED WITH RPUT ALL) *------------------------------------------------------ C SB5900 BEGSR C 1 DO C#10 #XP rows C EVAL #Q = #XP dst row C MOVEA #TO(#Q) #T1 src row C 1 DO C#10 #YP cols C EVAL #E = #YP dst pos C EVAL #CV = #T1(#E) src pos red C EXSR SB4201 rget char C IF #CR = C#CHR AND #CV = C#CHR C EVAL *IN23 = *ON break C ENDIF C ENDDO C ENDDO C ENDSR *====================================================== /TITLE --- SB5099 --- FHIDE ITEM *------------------------------------------------------ * #XP,#YP - LOCAL VARIABLES (SHARED WITH RPUT ALL) *------------------------------------------------------ C SB5099 BEGSR C 0 DO C#9 #XP rows C EVAL #Q = #XP + 1 src row C EVAL #A = #L + #XP dst row C 0 DO C#9 #YP cols C EVAL #E = #YP + 1 src pos C EVAL #B = #I + #YP dst pos C EXSR SB5201 fget char C IF #CF = C#CHR range Ok! C EVAL #CC = ' ' C EXSR SB2202 put char C ENDIF C ENDDO C ENDDO C ENDSR *====================================================== /TITLE --- SB4200 --- RSET POS *------------------------------------------------------ * #Q - ROW 1..4 * #E - POS 1..4 * #CR - CHAR 'O'³' ' *------------------------------------------------------ C SB4200 BEGSR C *LIKE DEFINE #D #Q C *LIKE DEFINE #D #E C *DTAARA DEFINE #CR 1 C MOVEA #BO(#Q) #B1 C ENDSR *====================================================== /TITLE --- SB4201 --- RGET CHAR C SB4201 BEGSR C EXSR SB4200 rset pos C EVAL #CR = #B1(#E) C ENDSR *====================================================== /TITLE --- SB4202 --- RPUT CHAR C SB4202 BEGSR C EXSR SB4200 rset pos C EVAL #B1(#E) = #CR C MOVEA #B1 #BO(#Q) C ENDSR *====================================================== /TITLE --- SB5200 --- FSET POS *------------------------------------------------------ * #Q - ROW 1..4 * #E - POS 1..4 * #CF - CHAR 'O'³' ' *------------------------------------------------------ C SB5200 BEGSR C *DTAARA DEFINE #CF 1 C MOVEA #CO(#Q) #C1 C ENDSR *====================================================== /TITLE --- SB5201 --- FGET CHAR C SB5201 BEGSR C EXSR SB5200 fset pos C EVAL #CF = #C1(#E) C ENDSR *====================================================== /TITLE --- SB5202 --- FPUT CHAR C SB5202 BEGSR C EXSR SB5200 fset pos C EVAL #C1(#E) = #CF C MOVEA #C1 #CO(#Q) C ENDSR *====================================================== /TITLE --- SB5800 --- VSET POS *------------------------------------------------------ * #Q - ROW 1..4 --> ??-POS (USED #P) * #E - POS 1..4 --> ROW * #CV - CHAR 'O'³' ' *------------------------------------------------------ C SB5800 BEGSR C *DTAARA DEFINE #CV 1 C *LIKE DEFINE #Q #P C MOVEA #VO(#E) #V1 C EVAL #P = #K - #L C EVAL #P = #P + 2 C EVAL #P = #P - #Q C ENDSR *====================================================== /TITLE --- SB5801 --- VGET CHAR C SB5801 BEGSR C EXSR SB5800 vset pos C EVAL #CV = #V1(#P) C ENDSR *====================================================== /TITLE --- SB5802 --- VPUT CHAR C SB5802 BEGSR C EXSR SB5800 vset pos C EVAL #V1(#P) = #CV C MOVEA #V1 #VO(#E) C ENDSR *====================================================== /TITLE --- SB9999 --- EXIT PROGRAM C SB9999 BEGSR C EXFMT VBYE good bye C EVAL *INLR = *ON C RETURN C ENDSR ** #FO - items to create O 11 OO 12 OOO 13 OOOO 14 OO OO 22 OOOOO 24 OOOO O 24 OO OO 23 OO OO 23 OOO O 23 OOO O O 23 O OOO O 33 O OOO O 33 O OOO O 33 O OO OO OO 44 ** #Z2- 20 zeros to *IN array 00000000000000000000 ** #O2- 20 ones to *IN array 11111111111111111111 ** #O6- 6 ones to *IN array (left³right³rotate³create³down) 111111