+Lee Stewart Posted September 7, 2020 Author Share Posted September 7, 2020 1 hour ago, TheBF said: The Forth code I posted is used with a tolerance of 8 typically and it seems to work great even in Forth. It works to a point, but, for a tolerance of 8 pixels, that method hits all pixels (289) in a 17x17-pixel square, when it should be hitting only the pixels (197) in a 17-pixel-diameter circle. That is 47% more pixels than it should be hitting—seems a bit much to me. ...lee 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 7, 2020 Share Posted September 7, 2020 I guess it's a requirements compromise then. The code ran significantly faster than what I had (which was already 2X faster than the TI-Forth code) and when I used it in a test the result seemed to work just like the other version to my eye. Sprites collided and bounced back. Different horses for different courses... ? Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 8, 2020 Author Share Posted September 8, 2020 I think I found a problem with COINC and COINCXY in TI Forth, which I converted to ALC for fbForth. and would, of course, still be a problem! Here is the high-level Forth code from TI Forth: : COINC ( spr#1 spr#2 tol --- f ) ( 0= no coinc 1= coinc ) DUP * DUP + >R ( STACK: spr#1 spr#2 R: tol*tol+tol*tol) SPRDIST R> ( STACK: dist^2 2*tol^2) > 0= ; ( within tolerance? STACK: flag) As you can see the test, for distance d of the top left corners of two sprites from each other with a tolerance t, is d2 <= 2t2. I have no idea why the TI gurus doubled t2. If you make a square with one sprite’s upper left corner in the center and each edge t pixels from the center (making each side 2t pixels) the tolerance circle (radius = t) is inscribed within the square. With the above test, the 2t-pixel square is inscribed within the tolerance circle, which now has its radius equal to half the diagonal of the square = (2t2)1/2, which is larger by a factor of √2. A tolerance of 8 pixels is now 11.3 pixels! Convince me I am wrong. ...lee 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 8, 2020 Share Posted September 8, 2020 Lol. I don't think I can. I am just now over looking over what I translated it into. I did the same thing, just faster. I am writing a little "collider" to compare how well different COINC routines work. It's like a particle collider for sprites with one sprite coming from opposite sides of the screen. Perhaps they were purposely expanding the window to create a higher chance of coincidence? Even in Forth it's hard catch the asynchronous automotion sprites. HEX \ text macros improve speed of coicidence detection : 2(X^2) ( n -- 2(n^2) S" DUP * 2* " EVALUATE ; IMMEDIATE : <= ( n n -- ? ) S" 1- <" EVALUATE ; IMMEDIATE \ simple machine code optimizers for DIST CODE RDROP ( -- ) 05C7 , \ RP INCT, NEXT, ENDCODE CODE DXY ( x2 y2 x1 y1 --- dx dy ) \ Common factor for SP.DIST,SP.DISTXY C036 , \ *SP+ R0 MOV, \ pop x1->R0 6136 , \ *SP+ TOS SUB, \ pop y1-y2->tos 6016 , \ *SP R0 SUB, \ x1-x2->R0, keep stack location C0C4 , \ TOS R3 MOV, \ dup tos in r3, MPY goes into R4 38C4 , \ TOS R3 MPY, \ r3^2, result->r4 (tos) C080 , \ R0 R2 MOV, \ dup R0 3802 , \ R2 R0 MPY, \ RO^2 C581 , \ R1 *SP MOV, \ result to stack NEXT, \ 16 bytes ENDCODE ( factored DIST out from SPRDISTXY in TI-Forth) : DIST ( x2 y2 x1 y1 -- distance^2) \ distance between 2 coordinates DXY 2DUP + \ sum the squares (DXY is code word) DUP >R \ push a copy OR OR 8000 AND \ check out of range IF RDROP 7FFF \ throw away the copy, return 32K ELSE R> \ otherwise return the calculation THEN ; : SP.DIST ( #1 #2 -- dist^2 ) \ distance between 2 sprites POSITION ROT POSITION DIST ; : SP.DISTXY ( x y # -- dist^2 ) POSITION DIST ; ( 0 means no coinc ) : COINC ( sp#1 sp#2 tol -- ? ) 2(X^2) >R SP.DIST R> <= ; 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 8, 2020 Author Share Posted September 8, 2020 1 hour ago, TheBF said: Perhaps they were purposely expanding the window to create a higher chance of coincidence? I think I would rather trust the user to increase the tolerance. I just wish I could guess why they did it. Perhaps I should again try to grok how GPL does it using coincidence tables (see here). I think I had it once upon a time. It just does not seem worth the effort. ...lee 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 8, 2020 Share Posted September 8, 2020 I agree that the user should control it and that it is all too much effort for something that needs to be fast on a very slow machine. That's why I believe the pixel coordinate comparison makes more sense. The data is sitting there so just read it and difference it. My preliminary colliider tests showed that this VDP x,y comparison method works very well. I have some stuff on my plate but this week but I want to run the tests with a deferred word COINC and plug in different methods and view the sprites and where they actually collide. I will take a look at the GPL and see if any of it clicks. 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 8, 2020 Share Posted September 8, 2020 7 hours ago, Lee Stewart said: I think I would rather trust the user to increase the tolerance. I just wish I could guess why they did it. Perhaps I should again try to grok how GPL does it using coincidence tables (see here). I think I had it once upon a time. It just does not seem worth the effort. ...lee OK I don't fully understand all the logic but it again seems to be an exercise that leads to slower determination of coincidence albeit it creates symmetrical coincidence around the object from what I can see. It would be helpful to see how much code it takes to process these tables. Is there a way to find that code in the GPL interpreter? Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 8, 2020 Author Share Posted September 8, 2020 54 minutes ago, TheBF said: OK I don't fully understand all the logic but it again seems to be an exercise that leads to slower determination of coincidence albeit it creates symmetrical coincidence around the object from what I can see. It would be helpful to see how much code it takes to process these tables. Is there a way to find that code in the GPL interpreter? Yes. I believe so. It should be in the commented code of the console ROM for the GPL interpreter (see this thread: The TI-99/4A Operating System). I will take a look. ...lee 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 8, 2020 Author Share Posted September 8, 2020 1 hour ago, TheBF said: OK I don't fully understand all the logic but it again seems to be an exercise that leads to slower determination of coincidence albeit it creates symmetrical coincidence around the object from what I can see. It would be helpful to see how much code it takes to process these tables. Is there a way to find that code in the GPL interpreter? I don’t know whether this is enough of the code to get the gist, but here it is: Spoiler TSTRTN B @RETNC RESTORE PROGRAM COUNTER * COINCIDENCE ROUTINE FOR INSERTION INTO REL4 INTERPRETER * UPON ENTRACE TO THIS ROUTINE AT LABEL 'COINC' THE * REGISTERS ARE ASSUMED TO BE SET UP: * MSBY R2=Y2 IN MSBY AND X2 IN LSBY; * MSBY R0=Y1 IN MSBY AND X1 IN LSBY; * IT IS ALSO ASSUMED THAT THE GROM'S INTERNAL ADDRESS IS SET * UP PREPARED TO READ (FOLLOWING THE COINC INSTRUCTION): * - A ONE BYTE GRANULARITY VALUE, FOLLOWED BY: * - A TWO BYTE ADR. POINTING TO THE COINCIDENCE TABLE. * THE TABLE IS ASSUMED TO RESIDE IN GROM, AND HAVE THE * FOLLOWING FORMAT: * BYTE 0- TV = VERTICAL BIT SIZE OF TABLE LESS 1 * BYTE 1- TH = HORIZ. BIT SIZE OF TABLE LESS 1 * BYTE 2- V1 = VERTICAL DOT SIZE OF OBJECT 1/2**GR * BYTE 3- H1 = HORIZ. DOT SIZE OF OBJECT 1/2**GR * BYTES 4 ON - THE BIT TABLE ITSELF; THE BITS ARE * ARRANGED SUCH THAT THE FIRST (TH+1) BITS REPRESENT BOOLEAN * CONICIDENCE VALUES CORRESPONDING TO A DELTA Y (Y1-Y2) OF -V1 * THRU -V1+TV AND DELTA X (X1-CX2) VALUES -H1 THRU -H1+TH * * ENTRY = BR TABLE COINC MOV R0,R8 MOV R8,R3 FIRST GET DELTA Y AND DELTA X SB R2,R3 R3= Y1-Y2= DELTA Y SWPB R8 GET X1 IN MSBY SWPB R2 GET X2 IN MSBY SB R2,R8 R8 X1-X2 = DELTA X MOVB *R13,R0 SET RESLN AND TABLE POINTER SRL R0,8 R0 = GRAN MOVB *R13,R5 SWPB R5 MOVB *R13,R5 SWPB R5 R5 = TABLE POINTER BL @PUTSTK SAVE GROM PC * * NOW GET TV,TH,V1,H1, OUT OF THE 1ST 4 BYTES OF TABLE * MOVB R5,@GWAOFF(R13) PUT OUT TABLE POINTER LSBY SWPB R5 MOVB R5,@GWAOFF(R13) PUT OUT TABLE POINTER MSBY SWPB R5 MOVB *R13,R2 R2=TV(MSBY) NOP MOVB *R13,R1 R1=TH(MSBY) NOP MOVB *R13,R6 R6=V1(MSBY) NOP MOVB *R13,R7 R7=H1(MSBY) * NOW ON WITH THE SHOW, THE REGISTERS ARE NOW SET UP AS: * R0= GRANULARITY; * MSBY R1= TH = CONICIDENCE TABLE HORIZONTAL SIZE -1 * MSBY R2= TV = CONICIDENCE TABLE VERTICAL SIZE -1 * MSBY R3= Y1 - Y2 = DELTA Y * MSBY R8= X1 - X2 = DELTA X * R5= PNTR TO COINCIDENCE TABLE IN GROM * MSBY R6= V1 = VERTICAL SIZE OF OBJECT ONE IN DOTS * MSBY R7= H1 = HORIZ. SIZE OF OBJECT ONE IN DOTS * R13 = GROM READ ADR. * MOV R0,R0 IF GRANULARITY IS 0, DON'T SHIFT JEQ DNTSHF BECAUSE 9900 SHIFT BY 0 IS 16 SRA R3,R0 DIVIDE DELTA Y BY (2** GRAN) SRA R8,R0 DIVIDE DELTA X BY (2** GRAN) DNTSHF AB R7,R8 R8 = B = H1 + DELTA X JLT NOCOIN AB R6,R3 R3 = A = V1 +DELTA Y JLT NOCOIN CB R3,R2 A::TV JGT NOCOIN CB R8,R1 B::TH JGT NOCOIN RANGE TEST PASSED? SRL R1,8 NOW COMPUTE TABLE INDEX INC R1 R1=TH+1 SRL R3,8 R3=A MPY R3,R1 R2=A*(TH+1) SRL R8,8 R8=B A R8,R2 R2= INDEX. COMPUTE TABLE & BIT POSN MOV R2,R0 R0 = INDEX ALSO ANDI R2,>FFF8 R2 = ROUNDED DOWN TO LOWER MULT OF 8 S R2,R0 R0 = BIT DISPLACEMENT (0= LEFTMOST) SRA R2,3 R2 = BYTE INDEX INTO TABLE A R5,R2 R2 = ACTUAL ADDRESS OF BYTE C *R2+,*R2+ INC PNTR BY 4 FOR 4 BYTE HEADER MOVB R2,@GWAOFF(R13) PULL PROPER BYTE FROM GROM INC R0 MOVB @R2LSB,@GWAOFF(R13) LI R2,>2000 MOVB *R13,R3 R3 = THE BYTE FROM THE TABLE SLA R3,R0 GET PROPER BIT INTO THE STATUS CARRY JOC YUP IF BIT IS 0, NO COINCIDENCE NOCOIN CLR R2 NO, WE HAVE COINCIDENCE YUP MOVB R2,@STATUS YES, WE HAVE COINCIDENCE JMP TSTRTN Personally, I am not sure it is worth the effort. I am chewing on using just the tolerance square, as I think you are (were) doing—a lot quicker, for sure. I may try to use a user-settable flag to do it either way, but I only have 162 bytes left in that bank. It might be enough. ...lee Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 8, 2020 Share Posted September 8, 2020 56 minutes ago, Lee Stewart said: I don’t know whether this is enough of the code to get the gist, but here it is: Reveal hidden contents TSTRTN B @RETNC RESTORE PROGRAM COUNTER * COINCIDENCE ROUTINE FOR INSERTION INTO REL4 INTERPRETER * UPON ENTRACE TO THIS ROUTINE AT LABEL 'COINC' THE * REGISTERS ARE ASSUMED TO BE SET UP: * MSBY R2=Y2 IN MSBY AND X2 IN LSBY; * MSBY R0=Y1 IN MSBY AND X1 IN LSBY; * IT IS ALSO ASSUMED THAT THE GROM'S INTERNAL ADDRESS IS SET * UP PREPARED TO READ (FOLLOWING THE COINC INSTRUCTION): * - A ONE BYTE GRANULARITY VALUE, FOLLOWED BY: * - A TWO BYTE ADR. POINTING TO THE COINCIDENCE TABLE. * THE TABLE IS ASSUMED TO RESIDE IN GROM, AND HAVE THE * FOLLOWING FORMAT: * BYTE 0- TV = VERTICAL BIT SIZE OF TABLE LESS 1 * BYTE 1- TH = HORIZ. BIT SIZE OF TABLE LESS 1 * BYTE 2- V1 = VERTICAL DOT SIZE OF OBJECT 1/2**GR * BYTE 3- H1 = HORIZ. DOT SIZE OF OBJECT 1/2**GR * BYTES 4 ON - THE BIT TABLE ITSELF; THE BITS ARE * ARRANGED SUCH THAT THE FIRST (TH+1) BITS REPRESENT BOOLEAN * CONICIDENCE VALUES CORRESPONDING TO A DELTA Y (Y1-Y2) OF -V1 * THRU -V1+TV AND DELTA X (X1-CX2) VALUES -H1 THRU -H1+TH * * ENTRY = BR TABLE COINC MOV R0,R8 MOV R8,R3 FIRST GET DELTA Y AND DELTA X SB R2,R3 R3= Y1-Y2= DELTA Y SWPB R8 GET X1 IN MSBY SWPB R2 GET X2 IN MSBY SB R2,R8 R8 X1-X2 = DELTA X MOVB *R13,R0 SET RESLN AND TABLE POINTER SRL R0,8 R0 = GRAN MOVB *R13,R5 SWPB R5 MOVB *R13,R5 SWPB R5 R5 = TABLE POINTER BL @PUTSTK SAVE GROM PC * * NOW GET TV,TH,V1,H1, OUT OF THE 1ST 4 BYTES OF TABLE * MOVB R5,@GWAOFF(R13) PUT OUT TABLE POINTER LSBY SWPB R5 MOVB R5,@GWAOFF(R13) PUT OUT TABLE POINTER MSBY SWPB R5 MOVB *R13,R2 R2=TV(MSBY) NOP MOVB *R13,R1 R1=TH(MSBY) NOP MOVB *R13,R6 R6=V1(MSBY) NOP MOVB *R13,R7 R7=H1(MSBY) * NOW ON WITH THE SHOW, THE REGISTERS ARE NOW SET UP AS: * R0= GRANULARITY; * MSBY R1= TH = CONICIDENCE TABLE HORIZONTAL SIZE -1 * MSBY R2= TV = CONICIDENCE TABLE VERTICAL SIZE -1 * MSBY R3= Y1 - Y2 = DELTA Y * MSBY R8= X1 - X2 = DELTA X * R5= PNTR TO COINCIDENCE TABLE IN GROM * MSBY R6= V1 = VERTICAL SIZE OF OBJECT ONE IN DOTS * MSBY R7= H1 = HORIZ. SIZE OF OBJECT ONE IN DOTS * R13 = GROM READ ADR. * MOV R0,R0 IF GRANULARITY IS 0, DON'T SHIFT JEQ DNTSHF BECAUSE 9900 SHIFT BY 0 IS 16 SRA R3,R0 DIVIDE DELTA Y BY (2** GRAN) SRA R8,R0 DIVIDE DELTA X BY (2** GRAN) DNTSHF AB R7,R8 R8 = B = H1 + DELTA X JLT NOCOIN AB R6,R3 R3 = A = V1 +DELTA Y JLT NOCOIN CB R3,R2 A::TV JGT NOCOIN CB R8,R1 B::TH JGT NOCOIN RANGE TEST PASSED? SRL R1,8 NOW COMPUTE TABLE INDEX INC R1 R1=TH+1 SRL R3,8 R3=A MPY R3,R1 R2=A*(TH+1) SRL R8,8 R8=B A R8,R2 R2= INDEX. COMPUTE TABLE & BIT POSN MOV R2,R0 R0 = INDEX ALSO ANDI R2,>FFF8 R2 = ROUNDED DOWN TO LOWER MULT OF 8 S R2,R0 R0 = BIT DISPLACEMENT (0= LEFTMOST) SRA R2,3 R2 = BYTE INDEX INTO TABLE A R5,R2 R2 = ACTUAL ADDRESS OF BYTE C *R2+,*R2+ INC PNTR BY 4 FOR 4 BYTE HEADER MOVB R2,@GWAOFF(R13) PULL PROPER BYTE FROM GROM INC R0 MOVB @R2LSB,@GWAOFF(R13) LI R2,>2000 MOVB *R13,R3 R3 = THE BYTE FROM THE TABLE SLA R3,R0 GET PROPER BIT INTO THE STATUS CARRY JOC YUP IF BIT IS 0, NO COINCIDENCE NOCOIN CLR R2 NO, WE HAVE COINCIDENCE YUP MOVB R2,@STATUS YES, WE HAVE COINCIDENCE JMP TSTRTN Personally, I am not sure it is worth the effort. I am chewing on using just the tolerance square, as I think you are (were) doing—a lot quicker, for sure. I may try to use a user-settable flag to do it either way, but I only have 162 bytes left in that bank. It might be enough. ...lee Wow! That is a lot of code. Thanks for finding it. back of the napkin... (0 wait state thinking just to compare things) So it is 58 lines of code if we say the 9900 averages 18 clocks per instruction that is on the order of 350 uS. With 20 clocks as an average that's 386 uS. My difference method in Forth, including putting 3 parameters on the stack is ~1,500 uS. measured with the 9901 timer. Three parameters uses 234 uS. leaving 1266uS for the routine. In code I should be able to make that 5x faster... 253 uS. Still not that much better. Will have to do some tests. Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 8, 2020 Author Share Posted September 8, 2020 1 hour ago, TheBF said: back of the napkin... (0 wait state thinking just to compare things) So it is 58 lines of code if we say the 9900 averages 18 clocks per instruction that is on the order of 350 uS. With 20 clocks as an average that's 386 uS Well—remember that, even though all that code is executing on the no-wait, 16-bit bus, the tables are very slow GROM accesses. I do not know whether TI Basic or XB use the GPL COINC instruction, but, if they do, I would think there would need to be VRAM access, as well—also slow. I seem to remember, though, that the Basics use the tolerance square—now, I need to check! ...lee Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 8, 2020 Author Share Posted September 8, 2020 10 minutes ago, Lee Stewart said: Well—remember that, even though all that code is executing on the no-wait, 16-bit bus, the tables are very slow GROM accesses. I do not know whether TI Basic or XB use the GPL COINC instruction, but, if they do, I would think there would need to be VRAM access, as well—also slow. I seem to remember, though, that the Basics use the tolerance square—now, I need to check! Oops! Just remembered there are no sprites in TI Basic—so, just need to check XB code. ...lee Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 8, 2020 Author Share Posted September 8, 2020 55 minutes ago, Lee Stewart said: Well—remember that, even though all that code is executing on the no-wait, 16-bit bus, the tables are very slow GROM accesses. I do not know whether TI Basic or XB use the GPL COINC instruction, but, if they do, I would think there would need to be VRAM access, as well—also slow. I seem to remember, though, that the Basics use the tolerance square—now, I need to check! OK—Here is the RXB source (includes all of XB source) that includes the COINC routine. Look particularly at the CODIST routine for the distance between two sprites and its use by the COINC routine. Though there is a DIST routine, which is used for XB’s CALL DISTANCE( ) for both inter-sprite and sprite-to-pixel distances, it appears DIST is not used for COINC and that my memory was correct in that XB uses only the tolerance square, dx and dy without calculating the actual distance: Spoiler *********************************************************** TITL 'RXB 2015' *********************************************************** GROM >A000 *********************************************************** TITL 'EQUATES EXEC-359' *********************************************************** * GROM ADDRESSES *********************************************************** * EQUATES FOR ROUTINES FROM OTHER GROM SECTIONS * GROM >0000 GRINT EQU >0022 Greatest integer * GROM >6000 EQUATES SPRINT EQU >6016 Initialize sprites CHRTBL EQU >6018 RXB CALL CHRTBL load char set TOPL10 EQU >601A Return to main and re-init CHRTAB EQU >601C Load default character set SZRUN EQU >601E KILSYM EQU >6022 KILL SYMBOL TABLE ROUTINE AUTO1 EQU >602E Get arguments for LIST comman TOPL02 EQU >6030 RTN address for failing AUTOL EDITLN EQU >6032 Edit a line into the program GRSUB1 EQU >6034 Read data (2 bytes) from ERAM GWSUB EQU >6036 Write a few bytes of data to MSGBRK EQU >6048 * BREAKPOINT MSGTA EQU >6053 Message "try again" TOPLEV EQU >6372 RXB CALL USER branch CHKEND EQU >6A78 Check end of statement DISO EQU >6A7C ENTER EQU >6A7E ENT09 EQU >6A80 WARNZZ EQU >6A82 WARNING MESSAGE ROUTINE ERRZZ EQU >6A84 ERROR MESSAGE ROUTINE ERRZ EQU >6A84 ERRor routine READL1 EQU >6A86 Read a line from keyboard SZNEW EQU >63A5 RXB CALL NEW branch TOPL15 EQU >63DD RXB CALL USER branch SZSIZE EQU >65C9 RXB CALL SIZE branch * GROM >8000 DISPL1 EQU >8000 DELET EQU >8002 PRINT EQU >8004 INPUT EQU >8006 OPEN EQU >8008 CLOSE EQU >800A RESTOR EQU >800C NREAD EQU >800E CLSALL EQU >8012 RXB branch EOF EQU >801C ACCEPT EQU >801E SRDATA EQU >8020 REC EQU >8022 GRSUB2 EQU >802C GRSUB3 EQU >802E LINPUT EQU >8030 CHARS EQU >9CEA RXB Character Definitions * GROM >E000 GE025 EQU >E025 RXB branch EA module *********************************************************** * Equates for XMLs SYNCHK EQU >00 SYNCHK XML selector FILSPC EQU >01 Fill-space utility PARCOM EQU >01 PARse to a COMma selector CSTRIN EQU >02 Copy-string utility RANGE EQU >02 RANGE selector SEETWO EQU >03 SEETWO XML selector FADD EQU >06 Floating ADD FMUL EQU >08 Floating MULtiply FDIV EQU >09 Floating DIVide FCOMP EQU >0A Floating COMPare SADD EQU >0B Stack ADD SSUB EQU >0C Stack SUBtract CSNUM EQU >10 Convert String to Number CFI EQU >12 Convert to two byte integer FLTINT EQU >12 Convert floating to integer COMPCT EQU >70 PREFORM A GARBAGE COLLECTION GETSTR EQU >71 SYSTEM GET STRING MEMCHK EQU >72 MEMORY check routine: VDP XCNS EQU >73 Convert number to string * Warning Defualt changfd in >0079 PARSE EQU >74 Parse a value CONT EQU >75 Continue parsing EXECG EQU >76 Execute a XB stmt or program VPUSH EQU >77 Push on value stack VPOP EQU >78 Pop off value stack PGMCHR EQU >79 GET PROGRAM CHARACTER SYM EQU >7A Find SYMBOL entry SMB EQU >7B Find symbol table entry ASSGNV EQU >7C Assign VARIABLE SCHSYM EQU >7D Search symbol table SPEED EQU >7E SPEED UP XML CRUNCH EQU >7F Crunch an input line CIF EQU >80 Convert INTEGER to FLOATING P RTNB EQU >82 Return SCROLL EQU >83 SCROLL THE SCREEN IO EQU >84 IO utility (KW table search) GREAD EQU >85 READ DATA FROM ERAM GWRITE EQU >86 WRITE DATA TO ERAM DELREP EQU >87 REMOVE CONTENT FROM VDP/ERAM MVDN EQU >88 MOVE DATA IN VDP/ERAM MVUP EQU >89 MOVE DATA IN VDP/ERAM VGWITE EQU >8A MOVE DATA FROM VDP TO ERAM GVWITE EQU >8B WRITE DATA FROM GRAM TO VRAM GREAD1 EQU >8C READ DATA FROM ERAM GDTECT EQU >8E ERAM DETECT&ROM PAGE 1 ENABLE SCNSMT EQU >8F SCAN STATEMENT FOR PRESCAN *********************************************************** * Temporary workspaces in EDIT VAR0 EQU >8300 TEMPORARY SP00 EQU >8300 SPRITE value PTFBSL EQU >8300 Ptr to 1st byte in SPEAK list PHLEN EQU >8300 PHrom data LENgth VARV EQU >8301 TEMPORARY PHRADD EQU >8301 PHRom ADDress ACCUM EQU >8302 # OF BYTES ACCUMULATOR (4 BYTE STPT EQU >8302 TWO BYTES MNUM EQU >8302 Ussually a counter AAA1 EQU >8302 SP02 EQU >8302 SPRITE value PTLBSL EQU >8302 Ptr to last byte in SPEAK list VARY EQU >8304 PABPTR EQU >8304 Pointer to current PAB SP04 EQU >8304 SPRITE value PTEBSL EQU >8304 Ptr to end byte in SPEAK list * NOTE: PTEBSL points to the end of the temporary speak lis * whereas PTLBSL points to the last byte actually use * i.e. PTFBSL <= PTLBSL <= PTEBSL VARY2 EQU >8306 Use in MVDN only DFLTLM EQU >8306 Default array limit (10) CCPPTR EQU >8306 OFFSET WITHIN RECORED (1) * or Pointer to current column SP06 EQU >8306 SPRITE value PTFCIS EQU >8306 Ptr to 1st character in string RECLEN EQU >8307 LENGTH OF CURRENT RECORD (1) CCPADR EQU >8308 RAM address of current refs * or Actual buffer address or c VARC EQU >8308 CCPADD EQU >8308 RAM address of current color CCC1 EQU >8308 SPSAL EQU >8308 Location of sprite attribute l PTCCIS EQU >8308 Ptr to current character in st CALIST EQU >830A Call list for resolving refs RAMPTR EQU >830A Pointer for crunching STADDR EQU >830A Start address - usually for co SPTMP EQU >830A Temporary variable PTLCIS EQU >830A Ptr to last character in strin VAR2 EQU >830B BYTES EQU >830C BYTE COUNTER * or String length for GETSTR NMPTR EQU >830C Pointer save for pscan BBB1 EQU >830C PTFCIP EQU >830C Ptr to 1st character in phrase CHSAV EQU >830E CURINC EQU >830E Increment for auto-num mode VAR4 EQU >830E PTCCIP EQU >830E Ptr to current character in ph TOPSTK EQU >8310 Top of data stack pointer VAR5 EQU >8310 VAR5 through VAR5+3 used in RA PTLCIP EQU >8310 Ptr to last character in phras VAR6 EQU >8311 LINUM EQU >8312 Used to determine end of scan PTFBPH EQU >8312 Ptr to 1st byte in PHrom VAR7 EQU >8312 Used in CHARLY STRPTR EQU >8312 RXB PATCH CODE NMLEN EQU >8314 Current line for auto-num CURLIN EQU >8314 Current line for auto-num * or Starting line number for L PTCCPH EQU >8314 Ptr to current byte in PHrom VAR9 EQU >8314 Used in CHARLY XFLAG EQU >8316 SCAN FLAG-BITS USED AS BELOW PTLCPH EQU >8316 Ptr to last byte in PHrom DSRFLG EQU >8317 INTERNAL =60, EXTERNAL =0 (1) OPTFLG EQU >8317 Option flag byte during OPEN FORNET EQU >8317 Nesting level of for/next FNUM EQU >8317 Current file number for search *********************************************************** * Permanent workspace variables STRSP EQU >8318 String space begining STREND EQU >831A String space ending SREF EQU >831C Temporary string pointer SMTSRT EQU >831E Start of current statement VARW EQU >8320 Screen address (CURSOR) ERRCOD EQU >8322 Return error code from ALC STVSPT EQU >8324 Value-stack base RTNG EQU >8326 Return vector from 9900 code NUDTAB EQU >8328 Start of NUD table VARA EQU >832A Ending display location PGMPTR EQU >832C Program text pointer (TOKEN) EXTRAM EQU >832E Line number table pointer STLN EQU >8330 Start of line number table ENLN EQU >8332 End of line number table DATA EQU >8334 Data pointer for READ LNBUF EQU >8336 Line table pointer for READ INTRIN EQU >8338 Add of intrinsic poly constant SUBTAB EQU >833A Subprogram symbol table IOSTRT EQU >833C PAB list/Start of I/O chain SYMTAB EQU >833E Symbol table pointer FREPTR EQU >8340 Free space pointer CHAT EQU >8342 Current charater/token BASE EQU >8343 OPTION BASE value PRGFLG EQU >8344 Program/imperative flag FLAG EQU >8345 General 8-bit flag BUFLEV EQU >8346 Crunch-buffer destruction leve LSUBP EQU >8348 Last subprogram block on stack * FAC EQU >834A Floating-point ACcurmulator CCHAR EQU >834A Current character FAC1 EQU FAC+1 SPLFLG EQU >834B SPelL out phrase FLaG FAC2 EQU FAC+2 AAA EQU FAC+2 TOTTIM EQU >834C TOTal wait TIMe * NOTE: DATAD must follow immediately after TOTTIM. The * routine STDATA is counting on this fact! FAC3 EQU FAC+3 DATAAD EQU >834D Speech DATA ADdress FAC4 EQU FAC+4 CCC EQU FAC+4 FFF EQU FAC+4 FAC5 EQU FAC+5 PTLCIL EQU >834F Pointer To Last Character In L FAC6 EQU FAC+6 BBB EQU FAC+6 EEE EQU FAC+6 FAC7 EQU FAC+7 TIMLEN EQU >8351 TIMe LENgth of timing charact FAC8 EQU FAC+8 PHADDR EQU >8352 PHrom ADDRess FAC9 EQU FAC+9 FAC10 EQU FAC+10 DDD1 EQU FAC+10 TEMP1 EQU >8354 TEMPorary CPU location 1 FAC11 EQU FAC+11 FAC12 EQU FAC+12 FFF1 EQU FAC+12 TEMP2 EQU >8356 TEMPorary CPU location 2 FAC13 EQU FAC+13 FAC14 EQU FAC+14 EEE1 EQU FAC+14 READ EQU >8358 Address of speech peripheral * READ byte interface FAC15 EQU FAC+15 FAC16 EQU FAC+16 WRITE EQU >835A Address of speech peripheral * WRITE byte interface FAC17 EQU FAC+17 * ARG EQU >835C Floating-point ARGument ARG1 EQU ARG+1 PHDATA EQU >835D PHrom DATA ARG2 EQU ARG+2 PTCBED EQU >835E Ptr To Current Byte Ext Data ARG3 EQU ARG+3 ARG4 EQU ARG+4 LENCST EQU >8360 LEN of Current ext data STring ARG5 EQU ARG+5 ARG6 EQU ARG+6 LENWST EQU >8362 LEN of Whole ext data STring ARG7 EQU ARG+7 ARG8 EQU ARG+8 STRLEN EQU >8364 STRing LENgth TEMP4 EQU >8364 TEMP5 EQU >8366 * NOTE: BYTE1, BYTE2, and BYTE3 must be in consecutive memo * locations, and in the following order for SPGET to * work! BYTE1 EQU >8366 BYTE 1 BYTE2 EQU >8367 BYTE 2 BYTE3 EQU >8368 BYTE 3 TEMP6 EQU >8368 SPKSTS EQU >8369 SPeaK StaTus * FPERAD EQU >836C Value stack pointer ARG11 EQU ARG+11 ARG15 EQU ARG+15 ARG16 EQU ARG+16 * VSPTR EQU >836E Value stack pointer *********************************************************** * GPL Status Block HIVDP EQU >8370 Highest VDP Available * SUBSTK EQU >8373 SUBROUTINE STACK KEYBD EQU >8374 KEYBOARD SELCTION RKEY EQU >8375 KEY CODE EXPZ EQU >8376 Exponent in floating-point JOYY EQU >8376 JOYSTICK Y POSITION JOYX EQU >8377 JOYSTICK X POSITION RANDOM EQU >8378 RANDOM NUMBER GENERATOR TIMER EQU >8379 TIMING REGISTER MOTION EQU >837A NUMBER OF MOVING SPRITES VDPSTS EQU >837B VDP STATUS REGISTER VDPSTT EQU >837B VDP STATUS REGISTER ERCODE EQU >837C STATUS REGISTER CB EQU >837D Character Buffer *********************************************************** RAMTOP EQU >8384 Highest address in ERAM RAMFRE EQU >8386 Free pointer in the ERAM RSTK EQU >8388 Subroutine stack base * (Starts at >8A) RAMFLG EQU >8389 ERAM flag GRAMFL EQU >8389 GRAM / VDP flag STKMIN EQU >83AF Base of data stack STKMAX EQU >83BD Top of data stack PRTNFN EQU >83CE Sound - previous tone finished *********************************************************** * VDP addresses SCRNBS EQU >02E0 Screen base addr for last lin NLNADD EQU >02E2 New LiNe ADDress ENDSCR EQU >02FE END of SCReen address SPRSAL EQU >0300 Sprite attribute list LODFLG EQU >0371 Auto-boot flag START EQU >0372 Line to start execution at * Temporary NOTONE EQU >0374 NO-TONE for SIZE in ACCEPT us * in FLMGRS (4 bytes used) SYMBOL EQU >0376 Saved symbol table pointer ONECHR EQU >0378 Used for CHRZ VRMSND EQU >0379 Sound blocks SPGMPT EQU >0382 Saved PGMPTR for continue SBUFLV EQU >0384 Saved BUFLEV for contiue SEXTRM EQU >0386 Saved EXTRAM for continue SAVEVP EQU >0388 Saved VSPRT for continue ERRLN EQU >038A On-error line pointer CSNTMP EQU >0390 Use as temporary stored place * or CSN TEMPORARY FOR FAC12 TABSAV EQU >0392 Saved main symbol table ponte AUTTMP EQU >0394 AUTOLD TEMPORARY IN SIDE ERRZ SLSUBP EQU >0396 Saved LSUBP for continue SFLAG EQU >0398 Saved on-warning/break bits SSTEMP EQU >039A To save subprogram program ta SSTMP2 EQU >039C Same as above. Used in SUBPRO MRGPAB EQU >039E MERGEd temporary for pab ptr RNDX2 EQU >03A0 Random number generator seed RNDX1 EQU >03A5 Random number generator seed INPUTP EQU >03AA INPUT TEMPORARY FOR PTR TO PR SPNUM EQU >03AA Sprite number temporary, also * in INPUTP in FLMGR ACCVRW EQU >03AC Temoporary used in ERRZZ, als * used in FLMGRS * or temporary for @VARW, @VARA ACCVRA EQU >03AE TRY AGAIN VALIDP EQU >03B0 Use as two values passing fro * or PTR TO STANDARD STRING IN VAL VALIDL EQU >03B2 VALIDATE code to READL1 * or Length of string in validate SIZCCP EQU >03B4 SIZE TEMPORARY FOR CCPADR SIZREC EQU >03B6 SIZE TEMPORARY FOR RECLEN * ACCTRY EQU >03B7 ACCEPT "TRY AGAIN" FLAG SIZXPT EQU >03B8 Save XPT in SIZE when "try ag CSNTP1 EQU >03BA CSN TEMPORARY FOR FAC10 * OLDTOP EQU >03BC Temporary used in ERRZZ, also * or Old top of memory for RELOCA CPTEMP EQU >03BC CCPPTR, RECLEN temp in INPUT NEWTOP EQU >03BE New top of memory for RELOCA VROAZ EQU >03C0 Temporary roll-out area SPRVB EQU >07FF Sprite velocity block. CRNBUF EQU >0820 CRuNch BUFfer address CRNEND EQU >08BE CRuNch buffer END VRAMVS EQU >0958 Default base of value stack *********************************************************** * IMMEDITATE VALUES NUMBR EQU >00 NUMERIC validate LISTZ EQU >02 X2 EQU >03 OLDZ EQU >05 RESEQZ EQU >06 SAVEZ EQU >07 MERGEZ EQU >08 DWNARR EQU >0A UPARR EQU >0B CHRTN EQU >0D BKGD EQU >20 BACKGROUND CHARACTER OFFSET EQU >60 OFFSET FOR VIDEO TABLES STRVAL EQU >65 Value in accum. is string val *********************************************************** * Editting command equates & keys or symbols BREAK EQU >02 Break key DLETE EQU >03 Delete key INSRT EQU >04 Insert key RECALL EQU >06 Edit-buffer recall CLRLN EQU >07 Clear-line key BACK EQU >08 Back-space key FORW EQU >09 Forward-space key DOWN EQU >0A Down-arrow key UPMV EQU >0B Up-arrow key VWIDTH EQU >1C Screen width (PRINT) SPACE EQU >20 Space key QUOTE EQU >22 " NUMBER EQU >23 # DOLLAR EQU >24 $ CURSOR EQU >1E+OFFSET CURSOR EDGECH EQU >1F+OFFSET EDGE character PLUS EQU >2B + COMMAT EQU >2C , MINUS EQU >2D - HYPEN EQU >2D + PERIOD EQU >2E . ZERO EQU >30 0 NINE EQU >39 9 COLON EQU >3A : SEMICO EQU >3B ; LESS EQU >3C < GREAT EQU >3E > A EQU >41 A F EQU >46 F *********************************************************** * BASIC TOKEN TABLE * EQU >80 spare token ELSEZ EQU >81 ELSE SSEPZ EQU >82 :: TREMZ EQU >83 $ IFZ EQU >84 IF GOZ EQU >85 GO GOTOZ EQU >86 GOTO GOSUBZ EQU >87 GOSUB RETURZ EQU >88 RETURN DEFZ EQU >89 DEF DIMZ EQU >8A DIM ENDZ EQU >8B END FORZ EQU >8C FOR LETZ EQU >8D LET BREAKZ EQU >8E BREAK UNBREZ EQU >8F UNBREAK TRACEZ EQU >90 TRACE UNTRAZ EQU >91 UNTRACE INPUTZ EQU >92 INPUT DATAZ EQU >93 DATA RESTOZ EQU >94 RESTORE RANDOZ EQU >95 RANDOMIZE NEXTZ EQU >96 NEXT READZ EQU >97 READ STOPZ EQU >98 STOP DELETZ EQU >99 DELETE REMZ EQU >9A REM ONZ EQU >9B ON PRINTZ EQU >9C PRINT CALLZ EQU >9D CALL OPTIOZ EQU >9E OPTION OPENZ EQU >9F OPEN CLOSEZ EQU >A0 CLOSE SUBZ EQU >A1 SUB DISPLZ EQU >A2 DISPLAY IMAGEZ EQU >A3 IMAGE ACCEPZ EQU >A4 ACCEPT ERRORZ EQU >A5 ERROR WARNZ EQU >A6 WARNING SUBXTZ EQU >A7 SUBEXIT SUBNDZ EQU >A8 SUBEND RUNZ EQU >A9 RUN LINPUZ EQU >AA LINPUT * EQU >AB spare token (LIBRARY) * EQU >AC spare token (REAL) * EQU >AD spare token (INTEGER) * EQU >AE spare token (SCRATCH) * EQU >AF spare token THENZ EQU >B0 THEN TOZ EQU >B1 TO STEPZ EQU >B2 STEP COMMAZ EQU >B3 , SEMICZ EQU >B4 ; COLONZ EQU >B5 : RPARZ EQU >B6 ) LPARZ EQU >B7 ( CONCZ EQU >B8 & (CONCATENATE) * EQU >B9 spare token ORZ EQU >BA OR ANDZ EQU >BB AND XORZ EQU >BC XOR NOTZ EQU >BD NOT EQUALZ EQU >BE = LESSZ EQU >BF < GREATZ EQU >C0 > PLUSZ EQU >C1 + MINUSZ EQU >C2 - MULTZ EQU >C3 * DIVIZ EQU >C4 / CIRCUZ EQU >C5 ^ * EQU >C6 spare token STRINZ EQU >C7 QUOTED STRING UNQSTZ EQU >C8 UNQUOTED STRING NUMZ EQU >C8 ALSO NUMERICAL STRING NUMCOZ EQU >C8 ALSO UNQUOTED STRING LNZ EQU >C9 LINE NUMBER CONSTANT * EQU >CA spare token ABSZ EQU >CB ABS ATNZ EQU >CC ATN COSZ EQU >CD COS EXPZZ EQU >CE EXP INTZ EQU >CF INT LOGZ EQU >D0 LOG SGNZZ EQU >D1 SGN SINZ EQU >D2 SIN SQRZ EQU >D3 SQR TANZ EQU >D4 TAN LENZ EQU >D5 LEN CHRZZ EQU >D6 CHR$ RNDZ EQU >D7 RND SEGZZ EQU >D8 SEG$ POSZ EQU >D9 POS VAL EQU >DA VAL STRZZ EQU >DB STR$ ASCZ EQU >DC ASC PIZ EQU >DD PI RECZ EQU >DE REC MAXZ EQU >DF MAX MINZ EQU >E0 MIN RPTZZ EQU >E1 RPT$ * EQU >E2 unused * EQU >E2 unused * EQU >E3 unused * EQU >E4 unused * EQU >E5 unused * EQU >E6 unused * EQU >E7 unused NUMERZ EQU >E8 NUMERIC DIGITZ EQU >E9 DIGIT UALPHZ EQU >EA UALPHA SIZEZ EQU >EB SIZE ALLZ EQU >EC ALL USINGZ EQU >ED USING BEEPZ EQU >EE BEEP ERASEZ EQU >EF ERASE ATZ EQU >F0 AT BASEZ EQU >F1 BASE * EQU >F2 spare token (TEMPORARY) VARIAZ EQU >F3 VARIABLE RELATZ EQU >F4 RELATIVE INTERZ EQU >F5 INTERNAL SEQUEZ EQU >F6 SEQUENTIAL OUTPUZ EQU >F7 OUTPUT UPDATZ EQU >F8 UPDATE APPENZ EQU >F9 APPEND FIXEDZ EQU >FA FIXED PERMAZ EQU >FB PERMANENT TABZ EQU >FC TAB NUMBEZ EQU >FD # VALIDZ EQU >FE VALIDATE * EQU >FF ILLEGAL VALUE ***************************************************** *********************************************************** * NOTE: FILES EXECSD, SUBS AND PART OF PSCANS ARE IN GROM 5 * AS BELOW: *-------NAME------------------ADDRESS---------BYTES LEFT--- * EXECS >A000 - >AD92 5 * SUBS >AD98 - >B4DC 2 * PSCANS >B4E0 - >B7FA 5 * * Some of the error calls at the end of EXECS file are * shared and directly addressed by SUBS file. Any change in * EXECS file which affects the address of error calls will * affect error reference in SUBS file. Make sure to edit * SUBS file in that situation. *********************************************************** XML CONT XML CONT used by subprogram BR LITS05 Build FAC entry and GETSTR BR EXEC Execute a program BR LINE BR DATAST BR ASC BR EXEC1 BR EXEC6D Save information on a break BR DELINK Delink symbol table entry BR CONV1 BR SQUISH Called in error routine in PS BR VALCD BR INTRND BR $ GA01C BR LNKRTN Routine to go back to XB prog GA01E BR SPCOL Clear breakpoint in line # ro BR UBSUB Spare BR $ BR $ *** Please let me know it you add * *** branches here since it will a * *** the address of link list. Sum LINK1 DATA LINK2 STRI 'SOUND' SOUND DATA XSOUND LINK2 DATA LINK3 STRI 'CLEAR' CLEAR DATA CLEAR LINK3 DATA LINK4 STRI 'COLOR' COLOR DATA COLOR LINK4 DATA LINK5 STRI 'GCHAR' GCHAR DATA GCHAR LINK5 DATA LINK6 STRI 'HCHAR' HCHAR DATA HCHAR LINK6 DATA LINK7 STRI 'VCHAR' VCHAR DATA VCHAR LINK7 DATA LINKA STRI 'CHAR' CHAR DATA CHARLY LINKA DATA LINKB STRI 'KEY' KEY DATA ZKEY LINKB DATA LINKC STRI 'JOYST' JOYST DATA ZJOYST LINKC DATA LINKD STRI 'SCREEN' KEY DATA BORDER LINKD DATA LINKE STRI 'VERSION' VERSION DATA VERS LINKE DATA LINKS1 STRI 'ERR' ERR DATA ERRWXY *********************************************************** * START EXECUTION OF A PROGRAM OR STATEMENT * DATA: * RAM(START) points into line number table at the * first line to execute * @PGMFLG contains >FF if executing a program or zero * if imperative statement *********************************************************** EXEC CZ @PRGFLG If program BS GA0AE DST V@START,@EXTRAM Line to start execution at DINCT @EXTRAM Pointer to text pointer CALL INTRND Initialize random number EXEC1 ST X2,@XPT Initialize screen display BR GA0B2 GA0AE DST CRNBUF,@PGMPTR Executing out of crunch buffe GA0B2 DST EXEC20,@RTNG Address of return from ALC DST NUDTB,@NUDTAB NUD table address for ALC XML EXECG Execute XB EXEC20 CASE @ERRCOD+1 Check type of return BR EXECND 0 - NORMAL END BR EXECBK 1 - BREAKPOINT BR EXECTR 2 - TRACE BR ERORZ 3 - ERROR BR WARNGZ 4 - WARNING BR ONERR 5 - ON ERROR BR UDF 6 - FUNCTION BR ONBRK 7 - ON BREAK BR CONCAT 8 - CONCATENATE STRINGS "&" BR ONWARN 9 - ON WARNING BR GPLCAL A - CALL STATEMENT WARNGZ CH >B0,@SUBSTK BS ERRSO * Stack overflow * ALLOW ROOM ON STACK FOR WARNING CALLS WRNN01 CALL WARNZZ ONLY WARNING MSG FROM XB SUPPORT BYTE 2 * NUMERIC OVERFLOW BR CLRRTN Clear ERRCOD and return * NORMAL END OF EXECUTION EXECND CZ @PRGFLG If imperative mode BR ERRRDY CALL CHRTAB Load the default character se B TOPL15 Return to top-level ERRRDY CALL ERRZZ Display * READY * BYTE 0 * TRACE-MODE turned on - display line number EXECTR CLR @VARW Clear upper address byte ST @XPT,@VARW+1 Get current x-pointer DADD NLNADD-3,@VARW Make a valid screen address DCH NLNADD+22,@VARW If might go off screen BR GA102 XML SCROLL SCROLL to next line DST NLNADD,@VARW Re-initialize screen address GA102 ST LESS+OFFSET,V*VARW Display open bracket "(" DINC @VARW Increment screen address CALL ASC Convert line # into ASCII ST GREAT+OFFSET,V*VARW Display close bracket ")" DSUB NLNADD-4,@VARW Update the x-pointer ST @VARW+1,@XPT CLRRTN DCLR @ERRCOD Clear the return vector XML RTNB Return to ALC * BREAKPOINT OR BREAK-KEY RECIEVED EXECBK CZ @PRGFLG If break or program BS ERRBRK DST @EXTRAM,@FAC8 @FAC8 : Source addr in ERAM DDECT @FAC8 Point to the line # CALL UBSUB1 Reset the breakpoint SCAN Get break key out of queue EXEC6C DST @PGMPTR,V@SPGMPT Save text pointer EXEC6D DST @EXTRAM,V@SEXTRM Save line number table pointe DST @VSPTR,V@SAVEVP Save value stack pointer DST @BUFLEV,V@SBUFLV Save crunch buffer level DST @LSUBP,V@SLSUBP Save last subprogram on stack ST @FLAG,V@SFLAG Save FLAG for continue AND >63,V@SFLAG Only warning and break bits ERRBRK CALL ERRZZ * BREAKPOINT BYTE 1 *********************************************************** * NUD / STATEMENT BRANCH TABLE *********************************************************** NUDTB BR RECX 'RECORD' 0 BR NBREAK 'BREAK' 0 BR NUNBRK 'UNBREAK' 0 BR NTRACE 'TRACE' 0 BR NUNTRC 'UNTRACE' 0 BR NREADX 'READ' 0 BR PRINTX 'PRINT' 0 BR SZRUNX 'RUN' 0 BR LINPUX Reserved for LINPUT 1 BR RESTOX 'RESTORE' 1 BR NRNDMZ 'RANDOMIZE' 1 BR INPUTX 'INPUT' 1 BR OPENX 'OPEN' 1 BR CLOSEX 'CLOSE' 1 BR NPI 'PI' 1 BR NMAX 'MAX' 1 BR NMIN 'MIN' 2 BR RPTZ01 'RPT$' 2 BR ACCEPX 'ACCEPT' 2 BR EOFX 'EOF' 2 BR ASC01 'ASC' 2 BR POS01 'POS' 2 BR VAL01 'VAL' 2 BR STRZ01 'STR$' 2 BR SEGZ01 'SEG$' 3 BR DELETX 'DELETE' 3 BR DISPLX 'DISPLAY' 3 BR LEN01 'LEN' 3 BR CHRZ01 'CHR$' 3 *RXB PATCH CODE FOR BASIC RND REPLACEMENT *********** BR NRND 'RND' 3 * The following are long branches to another GROM EOFX B EOF SZRUNX B SZRUN RECX B REC NREADX B NREAD PRINTX B PRINT RESTOX B RESTOR INPUTX B INPUT OPENX B OPEN CLOSEX B CLOSE ACCEPX B ACCEPT DISPLX B DISPL1 DELETX B DELET LINPUX B LINPUT *********************************************************** * FLAGS USED IN EXECUTION MODE: this needs to be checked * @FLAG BIT RESET SET * 0 * 1 Warning PRINT PRINT off * 2 Warning NEXT STOP * 3 Not in UDF Executing a UDF * 4 TRACE mode Normal mode * 5 * 6 BREAK allowed BREAK not allowed * 7 No LST/EDT protect LIST/EDIT protected *********************************************************** * ON WARNING {NEXT | STOP | PRINT} * ON WARNING NEXT - Causes warning messages to be ignored * and execution to continue as if a * warning never occurred * ON WARNING STOP - Causes a warning to be treated as an * error - i.e. the message is displayed * and execution is halted * ON WARNING PRINT - Causes the default warning handling to * be in effect, i.e. any warning * messages are printed and execution * continues *********************************************************** ONWARN XML PGMCHR GET OPTION CEQ PRINTZ,@CHAT If print BR GA1B7 AND >F9,@FLAG Turn on print and contiue B ONWRN5 GA1B7 CEQ STOPZ,@CHAT BR GA1C4 AND >FD,@FLAG Turn on print OR >04,@FLAG Turn on stop BR ONWRN5 GA1C4 CEQ NEXTZ,@CHAT * SYNTAX ERROR BR ERRSYN OR >02,@FLAG Turn off print AND >FB,@FLAG Turn off stop ONWRN5 XML PGMCHR Check for EOS ONWRN7 CALL CHKEND Error if not EOS BR ERRSYN If not EOS DCLR @ERRCOD XML CONT Continue *********************************************************** * ON ERROR {line number | STOP} * ON ERROR line number - causes the error routine to build * an error stack entry and pass * control to the line specified in * the most-recently executed * on-error-statement * ON ERROR STOP - causes the default error handling * conditions to be in effect. i.e. any * errors that occur cause execution to halt * an a message to be displayed *********************************************************** ONERR XML PGMCHR Get option CEQ LNZ,@CHAT If line # then find the line BR GA20E XML PGMCHR Get upper byte ST @CHAT,@FAC XML PGMCHR Get lower byte ST @CHAT,@FAC1 DST @ENLN,@FAC2 DSUB 3,@FAC2 Pointing to 1st line # * Consider both ERAM and RAM cases to get line # from the * line number table. Also reset the break bit. ONERR2 CALL GRSUB3 Get 2 bytes from either RAM/E BYTE FAC2 * FAC2 has the address DCEQ @EEE1,@FAC If found BS ONERR4 DCH @STLN,@FAC2 Not found BR ERRLNF DSUB 4,@FAC2 Goto next line BR ONERR2 ONERR4 DINCT @FAC2 DST @FAC2,V@ERRLN BR GA216 GA20E CEQ STOPZ,@CHAT * SYNTAX ERROR BR ERRSYN DCLR V@ERRLN Back to default error handlin GA216 BR ONWRN5 Finish up same as ON WARNING *********************************************************** * ON BREAK {NEXT | STOP} * ON BREAK NEXT - Causes any breakpoints which have been * set on statements to be ignored when the * statement is encountered and also masks * the shift-C key so that it is ignored * ON BREAK STOP - Causes the default break handling to be * in force., i.e. execution is halted and * the BREAKPOINT message is displayed on * the screen *********************************************************** ONBRK XML PGMCHR Get next char to find option CEQ STOPZ,@CHAT If stop option specified BR GA225 AND >BF,@FLAG break allowed B GA22D Don't change this to BR GA22D GA225 CEQ NEXTZ,@CHAT If next option number BR ERRSYN specified then syntax error OR >40,@FLAG If next option specified then * break NOT allowed GA22D BR ONWRN5 Finish up same as ON WARNING *********************************************************** * GPLCAL - If a call is made to a subprogram that does not * not exist either in the BASIC program itself or in the * internal GPL subprogram list then one final attempt is * made to find the subprogram at execution time by * searching for the subprogram in the console or a * peripheral. If not found there, then a * *SUBPROGRAM NOT FOUND error occurs * * Input: the subprogram name is in the FAC and the length * of the name is in FAC15 *********************************************************** GPLCAL CZ @RAMFLG Can't try if CPU program BR ERRSNF DSRL 8,@FAC15 Make name length a double DSUB @FAC15,@PGMPTR Point back at name DDEC @PGMPTR Point at name length DST @PGMPTR,@FAC12 Set pointer to name CALL LINK Issue 'Call Program Link' BYTE 10 * Search subprogram lists BR ONWRN7 If all ok, check-end and rtn BR ERRSNF If not found, error *********************************************************** * NUD FOR PI *********************************************************** NPI MOVE 8,G@CONPI,@FAC Load constant PI XML CONT CONPI BYTE >40,3,14,15,92,65,35,90 * 3.1415992653590E+00 *********************************************************** * NUD FOR MAX *********************************************************** NMAX CALL MAXMIN Combine MAX and MIN GT BR GA263 NMAXZ1 MOVE 8,@ARG,@FAC GA263 XML CONT *********************************************************** * NUD FOR MIN *********************************************************** NMIN CALL MAXMIN Combine MAX and MIN again GT BR NMAXZ1 XML CONT *********************************************************** * COMMON MAX / MIN ROUTINE *********************************************************** MAXMIN CALL LPAR Skip "(" parse, and insure , CH >63,@FAC2 Must be numeric BS ERRSNM XML VPUSH Push l.h. arg on stack XML PARSE PARSE up to ")" BYTE RPARZ CH >63,@FAC2 Must be numeric BS ERRSNM XML SPEED Must be BYTE SYNCHK * at a BYTE RPARZ * right parenthesis MOVE 8,@FAC,@ARG Save in ARG for compare XML VPOP Get l.h. arg back XML FCOMP Compare operands RTN * Initialize random number generator INTRND MOVE 10,G@X2SEED,V@RNDX2 RTN X2SEED BYTE >42,>03,>23,>15,>00 * = 33521, X2 INITIAL VAL X1SEED BYTE >43,>02,>3E,>2A,>17 * = 2624223, X1 INITIAL VAL *********************************************************** * * * RXB PATCH REPLACEMENT CODE FOR RND WITH TI BASIC RND * * * *********************************************************** * PSEUDO-RANDOM NUMBER GENERATOR * X(N+1) = (A*X(N)+C) MOD M; RND = X/M * WHERE: X = X2 * 1E7 + X1 * A = A2 * 1E7 + A1 * C = C2 * 1E7 + C1 * M = 1E14 * ASSUMPTIONS: * (1) All numbers are integers; fractional parts are * truncated * (2) If the variables listed below start in the ranges * specified. They will also end in the ranges specified * * CONSTANTS: 0 <= A2 < 5E6 ; 0 <= C2 < 1E7 * 0 <= A1 < 5E6 ; 0 <= C1 < 1E7 * VARIABLES: 0 <= X2 < 1E7 ; 0 <= T1 <= 1E14 ; 0 <= T2 < 1E * 0 <= X1 < 1E7 ; 0 <= T3 <= 1E14 ; 0 <= T4 < 1E * * STACK USAGE: * CONSTANT REFS CONTANT REFS CONTANT REF * +---------+ IN/OUT IN/OUT IN/OUT * | STACK+4 | X2*A1(F)(H) -- ---- -- ---- * +---------+ * | STACK+3 | T2 (C)(J) -- ---- -- ---- * +---------+ * | STACK+2 | T1 (B)(D) new X1 (E)(N) -- ---- * +---------+ * | STACK+1 |old X1(A)(G) T3 (K)(L) new X2 (M)(P) * +---------+ *********************************************************** * COMPUTE NEW VALUE FOR X1, SAVE IT IN V@RNDX1 * STACK * SREFS FAC CONTENTS * NRND MOVE 5,V@RNDX1,@FAC FAC = X1 * MOVE 5,V@RNDX1,@FAC fAC = X1 * CLR @FAC5 FAC = CLR * DCLR @FAC6 FAC = CLR * XML VPUSH (A) FAC = X1 * MOVE 8,G@RNDA1,@ARG ARG = A1 * XML FMUL FAC = X1*A1 * MOVE 8,G@RNDC1,@ARG ARG = C1 * XML FADD T1=FAC = X1*A1+C1 * XML VPUSH (B) FAC = T1 * MOVE 8,G@RNDEM,@ARG ARG = 1/1E7 * XML FMUL FAC = T1/1E7 * CALL GRINT T2=FAC = INT(T1/1E7) * XML VPUSH (C) FAC = T2 * MOVE 8,G@RNDEP,@ARG ARG = 1E7 * XML FMUL FAC = T2*1E7 * DSUB 8,@VSPTR * XML SSUB (D) X1=FAC = T1-T2*1E7 * MOVE 5,@FAC,V@RNDX1 FAC = X1 (new) * XML VPUSH (E) FAC = X1 * COMPUTE NEW VALUE FOR X2, SAVE IT IN V@RNDX2 * MOVE 5,V@RNDX2,@FAC FAC = X2 * CLR @FAC5 FAC = CLR * DCLR @FAC6 FAC = CLR * MOVE 8,G@RNDA1,@ARG ARG = A1 * XML FMUL FAC = X2*A1 * DADD 8,@VSPTR * XML VPUSH (F) FAC = X2*A1 * DSUB 24,@VSPTR * XML VPOP (G) FAC = X1 * DADD 32,@VSPTR * MOVE 8,G@RNDA2,@ARG ARG = A2 * XML FMUL FAC = X1*A2 * XML SADD (H) FAC = X2*A1+X1*A2 * MOVE 8,G@RNDC2,@ARG ARG = C2 * XML FADD FAC = X2*A1+X1*A2 * XML SADD (J) T3=FAC = X2*A1+X1*A2 * DSUB 16,@VSPTR * XML VPUSH (K) FAC = T3 * MOVE 8,G@RNDEM,@ARG ARG = 1/1E7 * XML FMUL FAC = T3/1E7 * CALL GRINT T4=FAC = INT(T3/1E7) * MOVE 8,G@RNDEP,@ARG ARG = 1E7 * XML FMUL FAC = T4*1E7 * XML SSUB (L) X2=FAC = T3-T4*1E7 * MOVE 5,@FAC,V@RNDX2 FAC = X2 (new) * COMPUTE NEW VALUE FOR RND, LEAVE IT IN FAC * MOVE 8,G@RNDEM,@ARG ARG = 1/1E7 * XML FMUL FAC = X2/1E7 * XML VPUSH (M) FAC = X2/1E7 * DADD 8,@VSPTR * XML VPOP (N) FAC = X1 * XML FMUL FAC = X1/1E7 * XML FMUL FAC = X1/1E14 * XML SADD (P)RND=FAC = (X2/1E7)+(X1/1E14) * XML CONT *********************************************************** * CONSTANTS FOR THE RANDOM NUMBER ROUTINE * RNDA2 BYTE >43,>01,>2B,>59,>52,>00,>00,>00 * = 1438982 * RNDA1 BYTE >42,>2A,>08,>15,>00,>00,>00,>00 * = 0420821 * RNDC2 BYTE >43,>02,>0B,>20,>30,>00,>00,>00 * = 2113248 * RNDC1 BYTE >43,>06,>36,>05,>13,>00,>00,>00 * = 6540519 RNDEP BYTE >43,>0A,>00,>00,>00,>00,>00,>00 * = 1E7 RNDEM BYTE >3C,>0A,>00,>00,>00,>00,>00,>00 * = 1/1E7 *********************************************************** * RXB BASIC RND REPLACEMENT FROM TI BASIC NRND ST >3F,@FAC * Exponent ST >4B,@VAR5 * Loop counter NRND1 RAND >63 * 0? CZ @RANDOM * No, go on BR NRND3 DEC @FAC * 0? CZ @FAC * End with 0 BS NRND4 * Go on BR NRND1 NRND2 RAND >63 * Till 100 NRND3 ST @RANDOM,*VAR5 * All digits CEQ >51,@VAR5 * Till >8351 BS NRND5 INC @VAR5 * Increase loop counter BR NRND2 NRND4 CLR @FAC1 * Set 0 NRND5 XML CONT ************************************************************ STRFCH XML PGMCHR XML PARSE BYTE RPARZ RTN STRGET CALL STRFCH CEQ >65,@FAC2 BR ERRSNM * STRING NUM MISMATCH RTN NUMFCH CALL STRFCH CEQ >65,@FAC2 BS ERRSNM * STRING NUM MISMATCH RTN CFIFCH XML CFI CEQ >03,@FAC+10 BS ERRBV * NUMERIC OVERFLOW RTN GETNUM CALL SUBLP3 CEQ >B3,@CHAT BR ERRSYN RTN ROWCOL CALL GETNUM DCGT 24,@FAC BS ERRBV DDEC @FAC ST @XPT,@MNUM ST @FAC1,@YPT CALL GETNUM DCGT 32,@FAC BS ERRBV DDEC @FAC ST @FAC1,@XPT RTN NGOOD XML PGMCHR NGOOD1 CHE >80,@CHAT BS ERRSYN * ? CALL SNDER CEQ >65,@FAC2 BR ERRSNM * STRING NUMBER MISMATCH DST >001C,@FAC DST @SREF,@FAC4 DST @BYTES,@FAC6 BR SNDASS SNDER XML SYM XML SMB XML VPUSH RTN CIFSND XML CIF SNDASS XML ASSGNV RTN GETLP ST @CB,@VAR0 ST @CB,@VARV SUB OFFSET,@VARV ST @VARV,V@0(@STRPTR) DINC @STRPTR RTN PUTLP ST V@0(@FAC4),@VAR0 ADD OFFSET,@VAR0 DINC @FAC4 RTN HFMT FMT DATA >E000 FEND RTN VFMT FMT DATA >E000 BYTE >9E FEND RTN SUBLP3 CALL NUMFCH CALL CFIFCH RTN CLRFAC CLR @FAC MOVE 7,@FAC,@FAC1 RTN *********************************************************** * * RXB PATCH CODE TO RESET ADDRESS FOR NRNDMZ ************** B NRNDMZ *********************************************************** * RANDOMIZE STATEMENT *********************************************************** NRNDMZ CALL CHKEND Seed provider? BS RNDM1 No * RANDOMIZE given a see value * (99,000,000,000,001 possible starting positions) * (Place-value is ignored in the input number) XML PARSE Parse the seed BYTE TREMZ * Up to end of statement CALL CKSTNM DCZ @FAC Check FAC for zero BS GA3B6 ST >46,@FAC 0 < FAC < 1E14 XML VPUSH Let FAC = X2*1E7+X1 MOVE 8,G@RNDEM,@ARG ARG = 1/1E7 XML FMUL FAC = X2+X1/1E7 CALL GRINT FAC = X2 MOVE 5,@FAC,V@RNDX2 FAC = X2 MOVE 8,G@RNDEP,@ARG ARG = 1E7 XML FMUL FAC = X2*1E7 XML SSUB FAC = X1 MOVE 5,@FAC,V@RNDX1 FAC = X1 XML CONT FAC = X1 GA3B6 DST @FAC,V@RNDX2 FAC = 0 DST @FAC,V@RNDX1 FAC = 0 XML CONT * RANDOMIZE given number seed value (use GPL RAND function) * (16K possible starting positions) RNDM1 DST >4201,@FAC FAC = >4201 CLR @FAC4 FAC4= >00 CALL RNDMZ DATA RNDX1 CALL RNDMZ Set up seed DATA RNDX2 XML CONT Continue on RNDMZ FETCH @FAC8 Fetch address of seed (high b FETCH @FAC9 Fetch address of seed (low by RAND 99 GPL Randomize ST @RANDOM,@FAC2 >00<=FAC+2<=FF SRL 2,@FAC2 >00<=FAC+2<=3F RAND 99 GPL Randomize ST @RANDOM,@FAC3 >00<=FAC+3<=FF SRL 2,@FAC3 >00<=FAC+3<=3F MOVE 5,@FAC,V*FAC8 Put in seed RTN CKSTNM CEQ >65,@FAC2 BS ERRSNM RTN FLT1 BYTE >40,>01,>00,>00,>00,>00,>00,>00 *********************************************************** * EXTENDED STRING PACKAGE * THE ROUTINES ARE: * LITS05 - Move a string literal from the program to the * string space * INTARG - Checks that an argument is a numeric and * converts it from floating point to an integer * PUSSTR - Checks that an argument is a string and pushes * it on the stack * CONCAT - Concatenates 2 strings together * SEG$ - Segments a string * LEN - Puts the length of a string in the FAC * CHR$ - Converts an integer into its ASCII character * STR$ - Converts a number into its string equivalent * VAL - Converts a string into its numeric equivalent * POS - Gives the position of one string within another * RPT$ - Generates a single string with multiple copies * of the original string * * AN ENTRY IN THE FAC LOOKS LIKE: * +------------+-----+----+-------------+-----------------+ * |addr of ptr | >65 | xx | addr of str | length of str | * +------------+-----+----+-------------+-----------------+ * FAC FAC2 FAC3 FAC4 FAC6 *********************************************************** * Support routine for functions to build FAC entry LITS05 CLR @FAC6 Need as a double-byte value DST @FAC6,@BYTES LENGTH FOR GETSTR ST @RAMTOP,@FAC8 Copy ERAM flag for later LITS07 XML GETSTR ALLOCATE STRING SPACE LITS08 DST >001C,@FAC SAVE ADDR OF STRING (SREF) DST @SREF,@FAC4 SAVE ADDR OF STRING DST >6500,@FAC2 INDICATES A STRING CONSTANT *********** COPY STRING INTO STRING SPACE ***************** LITS09 DCZ @BYTES If non-null string BS GA42B CZ @FAC8 BR GA420 MOVE @BYTES,V*TEMP5,V*SREF RTN * Else source string in ERAM GA420 DST @BYTES,@FFF1 FFF1 : BYTE COUNT DST @SREF,@EEE1 EEE1 : DESTINATION ADDR ON VD DST @TEMP5,@DDD1 DDD1 : Source addr in ERAM XML GVWITE Move data from ERAM to VDP GA42B RTN LITS06 CLR @FAC8 SET FLAG TO VDP BR LITS07 JUMP INTO CODE *********************************************************** * PUSSTR - Insures that the entry in the FAC is a string * and pushes it onto the stack. *********************************************************** PUSSTR CEQ >65,@FAC2 BR ERRSNM XML VPUSH PUSH THE ARGUMENT RTN *********************************************************** * CONCAT - CONCATENATES TWO STRINGS TOGETHER * INPUT : FLOATING POINT ACCUMULATOR ENTRIES * OUTPUT : CONCATENATED STRING AND (POSSIBLE) * ZEROED BACK-POINTERS FOR THE OLD STRINGS * USES : TEMP2, TEMP4 AND TEMP5 AS TEMPORARIES *********************************************************** CONCAT CLR @ERRCOD+1 CLEAR THE ERROR CODE CALL PUSSTR Push the string & get next to XML PARSE GET THE R.H. ARGUMENT BYTE CONCZ CEQ >65,@FAC2 If not string - error BR ERRSNM DST @FAC6,@BYTES GET R.H. LENGTH DADD V@6(@VSPTR),@BYTES ADD IN L.H. LENGTH DCH 255,@BYTES BR GA45B DST 255,@BYTES TRUNCATE IF TOO LONG WRNST1 CALL WARNZZ Display warning BYTE 19 * STRING TRUNCATED message GA45B DST @BYTES,@TEMP6 Keep length for later XML VPUSH XML GETSTR Alloccate the result string XML VPOP Retrieve R.H. MOVE 8,@FAC,@ARG XML VPOP Retrieve L.H. DST @FAC4,@TEMP5 Set ptr to L.H. ARG(for FREST DST @FAC6,@BYTES Length of L.H. ARG CLR @FAC8 Force VDP mode CALL LITS08 Set up FAC & copy L.H. ARG in DCZ @ARG6 If R.H. =0 don't copy BS CONC06 DST @SREF,@TEMP4 Get ptr to new string DADD @FAC6,@TEMP4 Ptr to where 2nd string begin DSUB @FAC6,@TEMP6 Length of 2nd string * (possibly truncated) BS CONC06 MOVE @TEMP6,V*ARG4,V*TEMP4 Copy in 2nd string DADD @TEMP6,@FAC6 Add in length of 2nd ARG * NOTE: FAC6 already contained length of 1st ARG from the * parse that was done on it CONC06 XML CONT Done. *********************************************************** * SEG$(A$,X,Y) - Extracts the desiginated string from A$. * X specifies the character position within A$ at * which the extraction begins. Y specifies the number * of characters to extract. * If X or Y is negative an error occurs. If X=0 an * error occurs. If Y=0 or X > Y then a null string is * is returned. If the ramaining length in A$ starting * at the postion specified by X is less than the length * specified by Y, then the remainder of A$ starting at * position X is returned. * INPUT - Control is turned over to SEG$ from PARSE. The * only requirement is that a SEG$ was encountered. * OUTPUT - The Floating Point Accumulator is set up with * the header for the segmented string. * USES - TEMP2 (Others in calls to GETSTR and LITS08) *********************************************************** SEGZ01 CALL LPAR Insure "(" parse and check ", CALL PUSSTR Push string and get next toke XML SPEED Get the position BYTE PARCOM * within the source string CALL INTARG CHECK & CONVERT ARG TO INTEGE DCZ @FAC CAN'T HAVE VALUE OF 0 BS ERRBV XML VPUSH PUSH THE ARG XML PARSE Get extraction length BYTE RPARZ XML SPEED Must have BYTE SYNCHK * ended on BYTE RPARZ * a right parenthesis CALL INTARG CHECK & CONVERT ARG TO INTEGE DST @FAC,@ARG Move extraction length XML VPOP Get position back DST @FAC,@ARG2 Move position XML VPOP Retrieve source string DST @ARG2,@TEMP2 Get position within string DCH @FAC6,@TEMP2 If position > length =>null BS SEGZ08 DADD @ARG,@TEMP2 Compute end of substring DSUB @FAC6,@TEMP2 Compute length beyond end DDEC @TEMP2 string DCGE 0,@TEMP2 BR SEGZ06 Fine if substring is shorter DST @FAC6,@ARG Else, truncate length of * substring DSUB @ARG2,@ARG Subtract position from source * length DINC @ARG Increment to include last cha SEGZ06 DST @ARG,@BYTES # of bytes needed for substri XML VPUSH Save source string entry XML GETSTR ALLOCATE RESULT STRING XML VPOP Restore source string entry DST @FAC4,@TEMP5 Pointer to source for FRESTR * LITS08 DADD @ARG2,@TEMP5 Pointer to start of substring DDEC @TEMP5 Decrement since zero-based DST @BYTES,@FAC6 Set length of string CLR @FAC8 FORCE VDP MODE CALL LITS08 Copy in & set up FAC XML CONT SEGZ08 DCLR @ARG Extract a null string BR SEGZ06 >>>JUMP ALWAYS<<< *********************************************************** * LEN(A$) - Calculate the length of a string and leave the * result in the FAC. * CONTROL - Turned over to NLEN from the parser. * USES - No temporaries. *********************************************************** LEN01 CALL PARFF Insure left parenthesis & par BR ERRSNM If not string value DST @FAC6,@FAC Length LEN02 XML CIF Convert integer to floating p XML CONT *********************************************************** * CHR$(X) - Takes integer value X and converts the number * into the ASCII representation for that number. * CONTROL - Turned over to NCHR by the parser. * OUTPUT - FAC is set up with the string entry * USES - Uses temproraries when invoking LITS06(LITSTR) *********************************************************** CHRZ01 CALL PARFF Insure left parenthesis & par CALL INTARG Convert into integer DST 1,@BYTES Create a length 1 string ST @FAC1,V@ONECHR Move the value to VDP(for LIT DST ONECHR,@TEMP5 Address of character CALL LITS06 Create string and set up FAC DST 1,@FAC6 Length of string XML CONT *********************************************************** * ASC(A$) - Takes the numeric value of the first character * in A$. *********************************************************** ASC01 CALL PARFF Insure left parenthesis & par BR ERRSNM If not string CZ @FAC7 Bad Argument? BS ERRBA ST V*FAC4,@FAC1 Get the first character CLR @FAC BR LEN02 USE COMMON CODE >>>JUMP ALWAY *********************************************************** * STR$(X) - Takes as its imput an integer X and converts it * to its string representation. * CONTROL - Turned over to STR$ by the parser. * USES - The usual temporaries used by string function * when it calls LITS06. Uses the Roll-out area * for a temporary storage area when allocating * the result string. * OUTPUT - FAC is set up in the usual manner for a string *********************************************************** STRZ01 CALL PARFF Insure left parenthesis & par BS ERRSNM If not numeric-error CLR @FAC11 Select XB floating type XML XCNS Convert the number to string CEQ SPACE,*FAC11 If leading space BR GA53E INC @FAC11 Suppress it out DEC @FAC12 Shorten the length GA53E CLR @BYTES Prepare for 2-byte value ST @FAC12,@BYTES+1 Get length of string MOVE @BYTES,*FAC11,V@VROAZ Put the string in VDP DST VROAZ,@TEMP5 Copy-from address(for LITSTR) CALL LITS06 Allocate and set up FAC DST @BYTES,@FAC6 Put in the length XML CONT *********************************************************** * VAL(A$) - Takes as its input a string, A$, and converts * the string into a number if the string is a * valid representation of a number. * CONTROL - From the parser. * OUTPUT - FAC contains the floating point number. *********************************************************** VAL01 CALL PARFF Insure left parenthesis & par BR ERRSNM If not string - error CZ @FAC7 Can't have null string BS ERRBA CALL VALCD So bad argument error BS ERRBA XML CONT * Short routine to parse a single argument enclosed in * parenthesis for a function or a subprogram and set * condition based upon whether the value parsed was a * string or a numeric. PARFF CEQ LPARZ,@CHAT BR ERRSYN XML PARSE BYTE >FF * CEQ >65,@FAC2 RTNC VALCD DST @FAC4,@TEMP5 Pointer to string DADD @FAC6,@TEMP5 Pointer to trailing length by DST @FAC6,@BYTES For suppressing trailing blan DINC @BYTES Prepare for undue subtraction GA57C DDEC @TEMP5 Keep track of end of string DDEC @BYTES Decrease length of string BS RTNSET End up with empty string, CEQ SPACE,V*TEMP5 Wild trailing blanks BS GA57C DINC @BYTES Allow for terminator XML VPUSH Save the ptr to the string XML GETSTR Get a new string XML VPOP Retrieve the ptr to the strin DST @FAC4,@TEMP5 Get the ptr to the string CLR @FAC8 Force VDP mode CALL LITS09 Copy the string and set up FA DADD @SREF,@BYTES Point to the trailing length DDEC @BYTES Point at the last character ST SPACE,V*BYTES Put in the terminator DST @SREF,@FAC12 Address for the conversion GA5A4 CEQ SPACE,V*FAC12 While leading spaces BR GA5AE DINC @FAC12 Skip leading blank BR GA5A4 GA5AE CLR @FAC2 Get rid of string (in case=0) CLR @FAC10 Assume no error XML CSNUM Convert it DCEQ @BYTES,@FAC12 Convert all of it? BS WRNNO Yes, check overflow & return RTNSET CEQ @VAR0,@VAR0 No, return with condition set RTNC *********************************************************** * POS(A$,B$,X) - Attempts to match the string, B$, in A$ * beginning at character # X in A$. If X is > LEN(A$), a * match is not found or A$ is the null string then the * returned value is 0. If B$ is the null string then the * returned value is 1. Otherwise, the returned value is * the column # of the 1st character matched in A$ * CONTROL - Fromn the parser. Returned through common code * IN LEN. * USES - Not temporaries - Utilizes FAC and ARG. *********************************************************** POS01 CALL LPAR Insure "(", parse , insure ", CALL PUSSTR STACK THE STRING AND GET TOKE XML SPEED Parse the match string and BYTE PARCOM * insure end on comma CALL PUSSTR STACK THE STRING AND GET TOKE XML PARSE Get position BYTE RPARZ XML SPEED Must have BYTE SYNCHK * ended on a BYTE RPARZ * right parenthesis CALL INTARG Check and convert it DCZ @FAC Value out of range BS ERRBV DST @FAC,@BYTES Keep the offset DDEC @BYTES Correct for position 0 XML VPOP Get match string back MOVE 8,@FAC,@ARG Put match in ARG XML VPOP Get source back CZ @FAC7 If source null BS POS12 CH @BYTES+1,@FAC7 OFFSET > LENGTH? BR POS12 Yes, no match possible CZ @ARG7 If null string BS POS06 DADD @BYTES,@FAC4 Adjust ptr for offset SUB @BYTES+1,@FAC7 Adjust length POS02 CHE @ARG7,@FAC7 Enough space left for a match BR POS12 No, no match possible DST @FAC4,@FAC Get first ARG DST @ARG4,@ARG Get second ARG ST @ARG7,@ARG8 And length of second POS04 CEQ V*FAC,V*ARG Compare the characters BR POS10 Didn't match DINC @FAC Next in source DINC @ARG Next in match DEC @ARG8 Reached end of match? BR POS04 Not yet, so loop POS06 INC @BYTES+1 Matched! Correct for 1 index POS08 DST @BYTES,@FAC Character position of match BR LEN02 Convert to floating point * NOTE: Utilizes the LEN code to do the conversion and * finish up. POS10 INC @BYTES+1 Step index of match character DEC @FAC7 Move 1 position down 1st DINC @FAC4 Argument BR POS02 Try to match again * JUMP ALWAYS POS12 CLR @BYTES+1 NO MATCH POSSIBLE BR POS08 *********************************************************** * RPT$(A$,X) - Creates a string consisting of X copies of * A$. If X is negative or non-numeric, an * exception occurs. If A$ is not a string, an * exception occurs. *********************************************************** RPTZ01 CALL LPAR Insure "(", parse, insure "," CALL PUSSTR Insure a string and push it XML PARSE Parse second argument BYTE RPARZ XML SPEED Must have BYTE SYNCHK * ended on a BYTE RPARZ * right parenthesis CALL INTARG Check numeric and convert DMUL V@6(@VSPTR),@FAC Compute result length DCZ @FAC1 BS GA649 WRNST2 CALL WARNZZ Give truncation message BYTE 19 * STRING TRUNCATED message DST 255,@FAC2 Make it a maximum string GA649 DST @FAC2,@BYTES Copy requested string length XML GETSTR Get the new string XML VPOP Retrieve the original string * At this point BYTES should still contain the length DST @FAC6,@ARG Copy original length in ARG DCZ @BYTES Zero copies requested BR GA659 DCLR @ARG So we copy zero!!!!!!! GA659 DEX @ARG,@BYTES Original length to BYTE DST @FAC4,@TEMP5 And also original start addr CLR @FAC8 Clear flag for LITS08 CALL LITS08 Create FAC and copy on copy * ARG contains total length now. DST @ARG,@FAC6 Store new length RPTZ02 DSUB @BYTES,@ARG Subtract one copy DCZ @ARG <<<<<THE WAY OUT BS XMLCON DADD @BYTES,@SREF Compute new start address DCH @ARG,@BYTES BR GA679 DST @ARG,@BYTES Truncate string GA679 MOVE @BYTES,V*TEMP5,V*SREF BR RPTZ02 ********************************************************** *********************************************************** * TRACE STATEMENT *********************************************************** NTRACE OR >10,@FLAG Set the trace bit XMLCON XML CONT Continue on *********************************************************** * UNTRACE STATEMENT *********************************************************** NUNTRC AND >EF,@FLAG Reset the trace bit XML CONT Continue on *********************************************************** * BREAK AND UNBREAK STATEMENTS *********************************************************** NBREAK ST >FF,@ARG BREAK flag CALL CHKEND Check for end of statement BR LINEGP If not goto LINEGP DDEC @PGMPTR Back up so CON will rescan en CZ @PRGFLG Rative without line # BR EXEC6C ERROLP CALL ERRZZ Only legal in a program BYTE 27 NUNBRK CLR @ARG UNBREAK flag for common CALL CHKEND Check for end of statement BS UNBK01 If end then goto UNBK01 LINEGP CALL LINE Get line # DST @ENLN,@ARG2 DSUB >03,@ARG2 1st line # LNGP1 DCHE @STLN,@ARG2 If line not found BR WRNLNF CALL GRSUB3 Read line # of data from ERAM BYTE >5E * (use GREAD1) or VDP * @ARG2: Source addr in ERAM/VDP, reset possible breakpoint DCEQ @FAC,@EEE1 If line found BS LNGP2 DSUB 4,@ARG2 Next line in VDP or ERAM BR LNGP1 * JUMP ALWAYS LNGP2 CZ @RAMTOP If ERAM exists BS GA6DA AND >7F,@EEE1 Assume UNBREAK flag CZ @ARG If BREAK flag BS GA6D1 OR >80,@EEE1 Set the breakpoint GA6D1 CALL GWSUB Write a few bytes of data to * ERAM (use GWRITE) BYTE >5E,>58,>01 * ARG2,EEE1,1 * @ARG2: Destination addr on ERA * @EEE1: Data * 1 : Byte count B LNGP2B GA6DA AND >7F,V*ARG2 Assume UNBREAK flag first CZ @ARG If BREAK flag BS LNGP2B OR >80,V*ARG2 Set the breakpoint LNGP2B CALL CHKEND Check for end of statement BS LNGP4 If end then continue XML SPEED Must be BYTE SYNCHK * at a BYTE COMMAZ * comma now BR LINEGP * JUMP ALWAYS WRNLNF CALL WARNZZ Note: warning not error BYTE 38 * 'LINE NOT FOUND' BR LNGP2B And contiue on * JUMP ALWAYS UNBK01 CALL UBSUB Clear all bkpt in line # tabl LNGP4 XML CONT Contiue * CLEAR ALL BREAKPOINTS UBSUB DST @STLN,@FAC8 END OF LINE # BUFFER GA6FF CALL UBSUB1 Reset one line # at a time DADD 4,@FAC8 Got to the next line DCH @ENLN,@FAC8 End of table BR GA6FF RTN UBSUB1 CALL GRSUB3 Read the line # from ERAM/VDP * Reset possible bkpt too BYTE >52 * @FAC8: Source addr on ERAM/VD CALL GWSUB Write a few bytes of data to * ERAM(use GWRITE) or VDP BYTE >52,>58,>01 * FAC8,EEE1,1 * @FAC8: Destination adr in ERAM/V * @EEE1: Data * 1 : Byte count RTN *********************************************************** * USER DEFINED FUNCTIONS * Subroutine to store away the information of the tokens in * a function reference, go into the 'DEF' statement, * calculate the value of the expression and then resume * execution of the user's program after the reference. * An entry in the FAC and on the stack for a function * reference looks like: * +--------+-----+---------------------+--------+---------+ * | PGMPTR | >68 | string/numeric flag | SYMTAB | FREPTR | * +--------+-----+---------------------+--------+---------+ * FAC FAC2 FAC3 FAC4 FAC6 * * The 'PGMPTR' is where execution resumes after evaluating * the function. String (80)/numeric(00) flag is function * type. SYMTAB is the old symbol table pointer and FREPTR * is the old free space pointer. These are restored after * the function is evaluated. *********************************************************** UDF CZ @PRGFLG If imperative BR GA720 CZ @RAMTOP+1 And ERAM, error BR ERROLP GA720 CLR @FAC7 Assume no args DCLR @ERRCOD Clear the error code for cont CLR @ARG2 Safety for VPUSH CLR @FAC2 Sagety for VPUSH CEQ LPARZ,@CHAT BR GA73B XML VPUSH Save ptr to function definiti XML PARSE PARSE to get arg value BYTE >FF MOVE 8,@FAC,@ARG Save PARSE result XML VPOP Get S.T. ptr to function defi INC @FAC7 Indicate theat we have an arg GA73B ST @FAC7,@TEMP5 Move the parmeter count DST @FAC,@TEMP4 S.T. ptr to definition XML VPUSH Allow room for UDF result MOVE 8,@ARG,@FAC Retrieve parse result XML VPUSH Save parse result ST V*TEMP4,@FAC2 Get S.T. declarations ST @FAC2,@FAC3 Do this to save string bit * NOTE: THIS IS TO ALLOW THE CHECKING AFTER THE FUNCTION HA * BEEN EVALUATED TO MAKE SURE THE FUNCTION * TYPE (STRING/NUMERIC) MATCHES THE RESULT IT PRODUCE AND >07,@FAC2 Mask all but # of parameters CEQ @TEMP5,@FAC2 BR ERRIAL * Incorrect argument list error above. DST @PGMPTR,@FAC Will resume execution here ST >70,@FAC2 Entering parameter into symbo * table while in UDF statement executing AND >80,@FAC3 Mask all but string bit DSUB 16,@VSPTR Get below parse result DST @SYMTAB,@FAC4 Save current symbol table ptr DST @FREPTR,@FAC6 Save current free space ptr XML VPUSH Save the return info DADD 8,@VSPTR Get back to parse result *********** SHIFT EXECUTION TO FUNCTION DEFINITION ******** DST V@6(@TEMP4),@PGMPTR Set text ptr to definiti XML PGMCHR Get 1st character in the defi CH >A4,@SUBSTK Stack overflow BS ERRSO MOVE 24,@VAR0,V@VROAZ Roll out temporaries OR >08,@FLAG Set function flag for ENTER ST >80,@XFLAG Make calls look like ENTERX CEQ EQUALZ,@CHAT BR GA79C * NOTE: This is to keep the global/local variables correct * the event that a function uses another function in * its evaluation. CLR @FAC15 Create a dummy entry in table CALL ENT09 for no-paremter function DDECT @PGMPTR Back up to equal sign CLR V@2(@VSPTR) This is to keep ASSGNV(called * below) not to screw up in * case FAC2 happens to have a * value (greater) >65 BR GA79F GA79C CALL ENTER Enter the parameter GA79F XML PGMCHR Get the '=' (Checked in PSCAN AND >F7,@FLAG Reset to normal ENTERs MOVE 24,V@VROAZ,@>8300 ST >68,V@-6(@VSPTR) Correct stack entry ID DST V@SYMBOL,V@2(@SYMTAB) Fudge link to * get global values DST @SYMTAB,@FAC Set up for SMB XML SMB Get value space MOVE 8,@FAC,@FAC8 Destination XML VPOP Get arg back MOVE 8,@FAC,@ARG Argument value MOVE 8,@FAC8,@FAC Destination XML VPUSH Push to destination MOVE 8,@ARG,@FAC Argument value CEQ >65,@FAC2 If a string BR GA7E2 DCEQ >001C,@FAC If not temp BS GA7E2 DST V*FAC,@FAC4 Get new location of string * Parameter was allocated in S. GA7E2 XML PGMCHR Skip the '=' XML ASSGNV Assign the value to the param XML PARSE PARSE to end of function defi BYTE TREMZ **** CHECK FOR TYPE MATCH (STRING/STRING OR NUM/NUM)******* **** BETWEEN THE RESULT AND THE FUNCTION TYPE ************* CEQ >65,@FAC2 If result string BR GA7F6 CZ V@3(@VSPTR) If functional BS ERRSNM BR GA7FC not a string GA7F6 CZ V@3(@VSPTR) If functional BR ERRSNM ***** NOW RESTORE SYMBOL TABLE AND RESUME ***************** ***** EXECUTION AT THE ORIGINAL LINE ********************** GA7FC CALL DELINK Delink the parameter entry DST V@8(@VSPTR),@PGMPTR Manual pop to get ptr back DDEC @PGMPTR Back up text pointer XML PGMCHR Get next token XML CONT DELINK DST @SYMTAB,@TEMP5 Save addr of S.T. entry just * in case entry is a string * (must free the string) MOVE 4,V@4(@VSPTR),@SYMTAB Restore old symbol table * pointer and free space pointe * This handles the freeing of t * string value which was assign * to the parameter. CGE 0,V*TEMP5 If string parmeter BS GA84C DST V@6(@TEMP5),@TEMP5 Where the string is DCZ @TEMP5 If non-null string BS GA833 DST V@-3(@TEMP5),@TEMP2 Get backpointer DCHE @SYMTAB,@TEMP2 If not used BS GA833 DCLR V@-3(@TEMP5) Free up the string * This handles the special case of F$(X$)=X$ * The result, which was permanent, must be made a temp. GA833 CEQ >65,@FAC2 If string result BR GA84A DCHE @SYMTAB,@FAC If came from argument BS GA84A DCZ @FAC4 If non-null BS GA846 DCLR V@-3(@FAC4) Clear the backpointer GA846 DST >001C,@FAC Make it a temp GA84A BR GA856 If numeric parameter GA84C CZ @RAMTOP If ERAM exist BS GA856 DADD 8,@RAMFRE Remove 8 bytes of value GA856 DSUB 8,@VSPTR Trash the stack entry RTN And retrun ATTNUT XML PARSE BYTE RPARZ CALL CKSTNM CHECK FOR NUMERIC OR STRING XML SPEED Insure argument is in BYTE RANGE * range of 0-30 BYTE 0 DATA 30 SRL 1,@FAC1 0,1 : 0000 ATTENUATION * 2,3 : 0001 * 4,5 : 0010 * 6,7 : 0011 ETC... OR >F0,@FAC1 REGISTER BITS RTN *********************************************************** * SUBROUTINE TO SET POINTER TO EACH DATUM *********************************************************** DATAST DDEC @LNBUF Point to 1st byte of line ptr CALL GRSUB2 Read 2 bytes from VDP or ERAM BYTE LNBUF * (use GREAD1), @LNBUF: Source * * address in ERAM or VDP DST @EEE1,@DATA Put it in @DATA CALL SRDATA Look for 'DATA' on the line BR DATST1 OK, FOUND ANOTHER 'DATA' STMT DDECT @LNBUF NO DCEQ @STLN,@LNBUF BS GA887 DDEC @LNBUF Point to 1st token address BR DATAST GA887 CLR @DATA Indicate no data DATST1 RTN *********************************************************** * Subroutine to get line number and goto routine to display * it on the screen. *********************************************************** ASC CZ @RAMFLG BR GA897 DST V@-2(@EXTRAM),@ARG2 Get line # in BR GA8A5 GA897 DST 2,@FFF1 @FFF1 : Byte count DST @EXTRAM,@DDD1 @DDD1 : Source addr in ERAM DDECT @DDD1 XML GREAD1 Read data from ERAM DST @EEE1,@ARG2 @EEE1 : Destination addr on C GA8A5 AND >7F,@ARG2 Reset the breakpoint if any B DISO *********************************************************** * Code to decode error returned from ALC *********************************************************** ERORZ CASE @ERRCOD DECODE ERROR FROM INTERPRETER BR ERRSYN 0 SYNTAX ERROR BR ERRMEM 1 MEMORY FULL BR ERRBV 2 BAD VALUE BR ERRLNF 3 LINE NOT FOUND BR ERRSYN 4 SYNTAX BR ERRBS 5 BAD SUBSCRIPT BR ERRSNM 6 STRING-NUMBER MISMATCH BR ERRSO 7 STACK OVERFLOW BR ERRBA 8 BAD ARGUMENT BR ERRRWG 9 RETURN WITHOUT GOSUB BR ERRIAL A INCORRECT ARGUMENT LIST BR ERRFNN B FOR/NEXT NESTING BR ERRNWF C NEXT WITHOUT FOR BR ERRMUV D IMPROPERLY USED NAME BR ERRIAL E INCORRECT ARGUMENT LIST BR ERRRSC F RECURSIVE SUBPROGRAM CALL BR ERRSNF 10 SUBPROGRAM NOT FOUND BR ERROLP 11 ONLY LEGAL IN A PROGRAM BR ERRSNS 12 MUST BE IN SUBPROGRAM *********************************************************** * SUBROUTINE TO GET LINE # FOLLOWING 'BREAK', 'UNBREAK', * 'RESTORE' *********************************************************** LINE CEQ LNZ,@CHAT Should be line # reference BR ERRSYN XML PGMCHR Get high order line # ST @CHAT,@FAC Build result in FAC, FAC1 XML PGMCHR ST @CHAT,@FAC1 Low order line # XML PGMCHR Get token following line # RTN CONV1 CLR @FAC10 XML CSNUM Convert String to Number *********************************************************** ST @FAC10,V@CSNTP1 DST @FAC12,V@CSNTMP Save those in temporary, becaus * in ERROV : WARNING routine hav * FAC12 and FAC10 values changed *********************************************************** WRNNO CZ @FAC10 Numeric overflow BS GA8F9 CALL WARNZZ BYTE 2 GA8F9 RTN *********************************************************** * SUBROUTINE FOR 'GCHAR' *********************************************************** GCHAR CALL GPHV Get X,Y values GCHAR2 CALL NUMVAR Get pointer to return variabl MOVE 8,G@FLT1,@FAC Clear FAC ST @CB,@FAC1 Get the character SUB OFFSET,@FAC1 Remove screen offset CHE 100,@FAC1 BR GA919 EX @FAC1,@FAC2 DIV 100,@FAC1 INC @FAC GA919 XML ASSGNV Assign the value to the symbo * RXB PATCH CODE BR GCHARA *********************************************************** * SUBROUTINE FOR 'COLOR' *********************************************************** COLOR XML SPEED Must be BYTE SYNCHK * at a BYTE LPARZ * left parenthesis * RXB PATCH CODE COL08 DCLR @VAR0 Clear ALL pointer CEQ ALLZ,@CHAT ALL? BR COL09 No. ST ALLZ,@VAR0 Yes, store it in pointer DCLR @FAC Set 0 XML PGMCHR Skip ALL token. CALL COMMA2 Skip comma. BR COL21 Start ALL RXB routine COL09 CEQ NUMBEZ,@CHAT If sprite number specified BR COL20 CALL CHAR1 Check sprite number (SPNUM3) COL10 CALL SPCOL Put the color in SAL CEQ COMMAZ,@CHAT More color changes BR LNKRTN CALL CHAR2 Skip and get sprite number (S BR COL10 * This part for regular color change routine COL20 XML SPEED Parse the character BYTE PARCOM * set and insure a comma XML SPEED Insure in range of BYTE RANGE * 0<= x <= 14 * RXB PATCH CODE * BYTE 0,0,14 BYTE 0,0,16 COL21 DADD >080F,@FAC Color table addr(>0810 - >081 XML VPUSH Push table set address XML SPEED Parse the foreground color BYTE PARCOM * and insure a comma CALL RAN16 Error if >16 or <1 ST @FAC1,@VAR4 Save it SLL 4,@VAR4 Foreground color in 4 MSBits XML PARSE Get background color BYTE RPARZ CALL RAN16 Error if >16 or <1 OR @FAC1,@VAR4 Background color in 4 LSBits XML VPOP Get color table address ST @VAR4,V*FAC Load the colors into the tabl * RXB PATCH CODE CEQ ALLZ,@VAR0 ALL in pointer. BR COL22 No. MOVE 14,V*FAC,V@1(@FAC) Fill color table with values COL22 CEQ COMMAZ,@CHAT End of call. Go back. BR LNKRTN XML PGMCHR Skip "," BR COL08 Take care of the next set * CALL SPCOL -- Changes color of sprite. * Called also from SPRITE. SPCOL XML PARSE BYTE RPARZ * Get the color number CALL RAN16 Check range 1 - 16 ST @FAC1,V@3(@SPSAL) Store in SAL RTN *********************************************************** * INTARG - Insures that the value in FAC is a numeric, * converts it to integer, issues error message if * necessary or returns. *********************************************************** INTARG CH >63,@FAC2 If string - error BS ERRSNM CLR @FAC10 ASSUME NO ERROR OR WARNING DCLR @FPERAD XML FLTINT CZ @FAC10 If error BR ERRBV CGE 0,@FAC Can't be < zero BR ERRBV RTN * FAC IS SET UP WITH F.P. 1 JOYXY ST @VAR0,@FAC1 CZ @VAR0 If <>0 BR GA995 CLR @FAC (>0000000000000000) BR GA99D GA995 CGE 0,@VAR0 BS GA99D ST >BF,@FAC GA99D XML ASSGNV Assign the value RTN ST @FAC1,@VAR0 Keyboard selection CALL NUMVAR Get variable for key-code CEQ COMMAZ,@CHAT If not comma - error BR ERRSYN XML PGMCHR Get next character CALL NUMVAR Get variable for key-status ST @VAR0,@KEYBD Keyboard selection MOVE 8,G@FLT1,@FAC Set up float SCAN SCAN the keyboard CLR @KEYBD Clear the code(No affect on s RTNC Return scan condition code NUMVAR XML SYM Get the symbol name CLOG >C0,V*FAC Can't be string or function BR ERRMUV It is, IMPROPERLY USED NAME E XML SMB Get value pointer XML VPUSH Put on stack for ASSGNV RTN And return ATTREG DATA >8000,>A000,>C000, BYTE >9F,>BF,>DF,>FF,>00,>06 COMB CEQ LPARZ,@CHAT If not '(' - error BR ERRSYN RTN SQUISH MOVE 8,V*FAC8,@FAC Sneak it out DST @VSPTR,@FAC14 Now move stack to squish it DSUB @FAC8,@FAC14 out - # of bytes to move BS SQU05 If none to move MOVE @FAC14,V@8(@FAC8),V@-16(@FAC8) SQU05 DSUB 8,@VSPTR RTN *********************************************************** * SUBPROGRAM FOR CLEAR *********************************************************** CLEAR ALL SPACE+OFFSET Clear the screen ST 3,@XPT Initialize screen pointer BR LNKRT2 Return to caller *********************************************************** * SUBPROGRAM FOR VERSION *********************************************************** VERS CALL COMB Insure have left parenthesis CALL ERRC05 Get symbol information *---------------------------------------------------------- * Change version number to 110 6/16/1981 DST 2015,@FAC 8/17/2014 XML CIF Convert to floating point *---------------------------------------------------------- BR ASSRTN Assign and return to caller * INIALIZATION DATA FOR SOUND FLTS BYTE >42,>0B,>12,>22,>00,>00,>00,>00 SNDREG BYTE >01,>FF,>01,>04,>9F,>BF,>DF,>FF,>00 *********************************************************** * SUBPROGRAM FOR 'SOUND' * Builds 2 blocks in VDP RAM * 1st BLOCK : >01,<ATTENUATION FOR NOISE>,<INTERRUPT COUNT> * 2nd BLOCK : >04,>9F,>BF,>DF,>FF,>00 *********************************************************** XSOUND DCEQ VRMSND,@>83CC Insure previous sound started BS XSOUND MOVE 9,G@SNDREG,V@VRMSND CALL LPAR Duration in milliseconds CGE 0,@FAC Don't wait for completion BS GAA39 DNEG @FAC of previous sound DCLR @PRTNFN Make GPL interpeters stop pre GAA39 XML SPEED Insure duration BYTE RANGE * is in range BYTE 1 * of 1 - 4250 DATA 4250 * Convert duration into 1/60s of a second DMUL 6,@FAC Duration * 6 DDIV 100,@FAC (duration * 6) / 100 CZ @FAC1 If duration =0 BR GAA4D INC @FAC1 Set it to 1/60th of a second GAA4D ST @FAC1,V@VRMSND+2 3rd byte of the 1st block * | INTERUPT COUNT *********************************************************** * SOUND TABLE OF 10 BYTES IN CPU RAM (>00 - >09) * >00 - >05 : FREQUENCY CONTROL * >06 - >08 : ATTENUATION CONTROL * >09 : NOISE CONTROL(non-zero = noise encountered) * >0A : POINTER FOR CURRENT FREQENCY CONTROL * >0B : POINTER FOR CURRENT ATTENUATION CONTROL * >00 , >01 FOR REG 0; * >02 , >03 FOR REG 1; * >04 , >05 FOR REG 2; * REG0 : >8000, REG1 : >A000, REG3 : >C000 * INITIALIZE ATTENUATION CONTROL * REG0 : >9F, REG1 : >BF, REG2 : >DF *********************************************************** MOVE 12,G@ATTREG,@>8300 SOUND1 XML SPEED Parse the frequency value BYTE PARCOM * and insure a comma CALL CKSTNM Must be a numeric CGE 0,@FAC Noise if negative BR SOUND2 MOVE 8,G@FLTS,@ARG Constant 111834 XML FDIV P = 111834/FREQUENCY XML SPEED Insure in range BYTE RANGE BYTE 3 * Range: 3 - 1023 DATA 1023 * GET THE 4 L.S.Bits BITS AND 6 M.S.Bits OF 'P' DSRC 4,@FAC SRL 4,@FAC DOR @FAC,*STADDR 1st byte of frequency control byt * BIT 7 6 5 4 3 2 1 * 1 <REG> 0 <L.S.B. 4 OF * 2nd byte of frequency control byt * 0 0 <M.S.B. 6 of 'P' INCT @STADDR Advance ponter for next time CALL ATTNUT Get attenuation * BIT 7 6 5 4 3 2 1 * 1 <REG> 1 0 0 0 AND @FAC1,*VAR2 1 <REG> 1 <ATTN/2 DB> INC @VAR2 Advance pointer for next time * CHECK FOR END OF SOUND CALL SOUND3 CEQ RPARZ,@CHAT End of statement? BS SOUND5 XML SPEED If not right parenthesis BYTE SYNCHK * then must be at BYTE COMMAZ * a comma CEQ 6,@STADDR If not 3 regs yet BR SOUND1 * 3 sound regs already - so must be noise control XML SPEED Get frequency (should be nois BYTE PARCOM * and insure a comma CALL CKSTNM Must be a numeric value CGE 0,@FAC If not noise-error BS ERRBV * NOISE CONTROL SOUND2 CEQ >FF,@>8309 * BAD ARGUMENT ERROR BR ERRBA DNEG @FAC -(FREQUENCY) XML SPEED Insure in range BYTE RANGE * of 1 - 8 BYTE 1 * DATA 8 DEC @FAC1 0 - 7 (2nd BIT: 'T') * OTH, 1ST BITS: ST @FAC1,@>8309 OR >E0,@>8309 Noise control byte: * BIT 7 6 5 4 3 2 1 0 * 1 1 1 0 0 <T> < S > * PUT ATTENUATION IN THE 2ND BYTE OF 1ST BLOCK CALL ATTNUT ST @FAC1,V@VRMSND+1 * 1 1 1 1 < ATTN/2 DB> BR SOUND3 Go check for end of list SOUND5 CLR @VAR5 Pointer to sound table SND05 CZ @PRTNFN Wait untild previous BS SOUND6 SCAN Is finished and BR SND05 look for a break-key CEQ BREAK,@RKEY If not break-key BR SND05 BR EXEC6C If BREAK-KEY encountered * LOAD SOUND TABLE SOUND6 ST *VAR5,@>8400 SOUND ADDRESS PORT INC @VAR5 Next byte in table CEQ >0A,@VAR5 If not finished BR SOUND6 DST VRMSND,@FAC Where the 2 blocks are I/O 1,@FAC Start sound from VDP list BR LNKRTN Return to caller *********************************************************** * SUBPROGRAM FOR 'HCHAR' *********************************************************** HCHAR CALL HVCHR Get X, Y values character, # DCZ @FAC If 0 characters BS HCHAR2 HCHAR1 BYTE >08,>E0,>00,>FB * FMT '@VAR0' Display horizo DDEC @FAC Done yet? BR HCHAR1 No, finish it * RXB PATCH CODE HCHAR2 CEQ COMMAZ,@CHAT BS HCHAR XPTRTN ST @MNUM,@XPT Restore X-pointer LNKRTN XML SPEED Must be at BYTE SYNCHK * a right BYTE RPARZ * parenthesis LNKRT2 CALL CHKEND Check end of statement BR ERRSYN If not end-of-stmt , error CALL RETURN Return to caller *********************************************************** * SUBPROGRAM FOR 'VCHAR' *********************************************************** VCHAR CALL HVCHR Get X, Y values character, # DCZ @FAC If 0 characters BS VCHAR2 VCHAR1 BYTE >08,>E0,>00,>9E,>FB * FMT '@VAR0',>31 Display v DDEC @FAC Done yet? BS VCHAR2 Yes, return CZ @YPT If not at start of colunm BR VCHAR1 INC @XPT Move X-ptr to right one colun B VCHAR1 * RXB PATCH CODE VCHAR2 CEQ COMMAZ,@CHAT BS VCHAR BR XPTRTN *********************************************************** * SUBPROGRAM FOR 'CHAR' *********************************************************** CHARLY CALL COMB CHAR5 XML PGMCHR Skip "(" or "," * RXB PATCH CODE CEQ ALLZ,@CHAT BR GAB1F XML PGMCHR CALL COMMA2 ST ALLZ,@VAR0 DST 32,@FAC BR GAB28 GAB1F XML SPEED Get the first value BYTE PARCOM * and insure a comma XML SPEED Insure in range BYTE RANGE * of 32 - 143 * RXB PATCH CODE BYTE 30 DATA 159 GAB28 DSLL 3,@FAC Convert chr number to address DADD >0300,@FAC CORRECT FOR OFFSET DST @FAC,@VARY Save it XML PARSE Get string BYTE RPARZ CEQ >65,@FAC2 MUST BE STRING BR ERRSNM MOVE 4,@FAC4,@VAR5 VAR5 pointer to string value * Start defining character description. * VARY Address of RAM for character description. * VAR5 Pointer to string value. * VAR7 Length of string value. * VAR9 Temporary counter. * VAR9+1 Temporary counter. DCH 64,@VAR7 Max 4 characters at a time BR CHAR40 DST 64,@VAR7 IGNORE THE EXCESSES CHAR40 DCHE SPRVB,@VARY Don't have space for BS CHARL4 ST ZERO,@FAC Floating Point Accumulator (> MOVE 15,@FAC,@FAC1 DCZ @VAR7 Fill with zero BS CHAR50 DCHE 16,@VAR7 BS GAB6B MOVE @VAR7,V*VAR5,@FAC Move whatever DCLR @VAR7 BR CHAR50 GAB6B MOVE 16,V*VAR5,@FAC Move one character DSUB 16,@VAR7 Less num of bytes to move DADD 16,@VAR5 Move pointer CHAR50 ST >4A,@VAR9 Move pointer (>4A=FAC) ST 1,@VAR9+1 B GAB84 GAB82 INC @VAR9+1 GAB84 CGT 8,@VAR9+1 BS GABC3 CLR @BYTES Clear dot-building byte CHARL2 SLL 4,@BYTES For loop(2 chars per byte) ST *VAR9,@ARG CHE ZERO,@ARG If < 0 BR ERRBV CGT NINE,@ARG If in 0-9 BR CHARL3 CHE A,@ARG If > 9 but < A BR ERRBV CH F,@ARG If > F BS ERRBV CHARL3 SUB ZERO,@ARG Character - >30 CH 10,@ARG If in A-F BR GABB1 SUB 7,@ARG Correct for that too GABB1 OR @ARG,@BYTES Dot expression INC @VAR9 CLOG 1,@VAR9 1st half of row finished? BR CHARL2 Yes, do 2nd half * (each takes half byte) ST @BYTES,V*VARY Load characters DINC @VARY BR GAB82 Load characters on next row GABC3 DCZ @VAR7 More char to describe BR CHAR40 * RXB PATCH CODE CEQ ALLZ,@VAR0 BR CHARL4 DCLR @VAR0 CHRFIL MOVE 8,V@>0400,V@>0408(@VAR0) DADD 8,@VAR0 DCEQ 94*8,@VAR0 BR CHRFIL CHARL4 CEQ COMMAZ,@CHAT More specified? BS CHAR5 BR LNKRTN Return *********************************************************** * SUBPROGRAM FOR 'KEY' *********************************************************** KEY CALL SPAR GET KEY UNIT * RXB PATCH LABEL ************ GABD1 XML SPEED Insure in range BYTE RANGE * of 0 - 5 BYTE 0 DATA 5 CALL KEYJOY Get variables for code and st * and scan keyboard * KEYJOY returns key status BS KEY1B KEY STATUS = 1 DNEG @FAC Assume status = -1 CEQ >FF,@RKEY But correct if = 0 BR KEY1B DCLR @FAC KEY STATUS = 0 KEY1B XML ASSGNV Assign value in variable DST >4001,@FAC Re-store F.P. 1 in FAC CZ @RKEY If key-code = 0 BS KEY2 CEQ >FF,@RKEY No key depressed, BS KEY1C key code assigned to -1 * FORMAT FOR KEYCODES ABOVE 99 ADDED FOR 99/4A HIGHEST * KEYCODE (OTHER THAN >FF) IS >C6=198 * 5/7/81 CHE 100,@RKEY BR GAC04 INC @FAC SUB 100,@RKEY ST @RKEY,@FAC2 FLOATING FORMAT (>4001__00000 B GAC07 GAC04 ST @RKEY,@FAC1 FLOATING FORMAT (>40__0000000 GAC07 BR KEY2A KEY1C DNEG @FAC KEY CODE ASSIGNED TO -1 BR KEY2A KEY2 DCLR @FAC (>000000000000000) KEY2A XML ASSGNV ASSIGN VALUE TO VARIABLE * RXB PATCH CODE ************* * BR LNKRTN BR SUBRTN *********************************************************** * RXB PATCH WAS SUBPROGRAM FOR 'JOYSTICK' *********************************************************** CALL SPAR KEY UNIT XML SPEED Insure in range BYTE RANGE * of 1 - 4 BYTE 1 DATA 4 CALL KEYJOY GET VARIABLES FOR X, Y * AND SCAN KEYBOARD ST @JOYY,@VAR0 JOYSTICK Y POSITION CALL JOYXY -4 to +4 DST >4001,@FAC Re-store F.P. 1 in FAC ST @JOYX,@VAR0 JOYSTICK X POSITION CALL JOYXY -4 to +4 BR LNKRTN *********************************************************** * INSURE LEFT PARENTHESIS AND THEN PARSE TO A COMMA *********************************************************** * RXB PATCH CODE LPAR CEQ COMMAZ,@CHAT BS CPAR XML SPEED Must be BYTE SYNCHK * at a BYTE LPARZ * left parenthesis BR GAC35 CPAR XML SPEED BYTE SYNCHK BYTE COMMAZ * RXB PATCH LABEL *********** GAC35 XML PARSE Do the parse BYTE COMMAZ * Stop on a comma XML SPEED Must be BYTE SYNCHK * at a BYTE COMMAZ * comma RTN *********************************************************** * SUBROUTINE FOR 'RANGE' USED IN ALL SOUND AND GRAPHICS *********************************************************** RAN16 XML SPEED Insure in range BYTE RANGE * of 1 to 16 BYTE 1 DATA 16 DEC @FAC1 Adjust to internal range RTN *********************************************************** * SUBROUTINE TO GET ROW, COLUMN VALUES *********************************************************** * RXB PATCH CODE GPHV CALL LPAR Insure '(', parse, insure ',' * RXB PATCH CODE GPHVRC XML SPEED Insure in range BYTE RANGE * of 1 - 24 BYTE 1 DATA 24 DEC @FAC1 Adjust to internal range ST @XPT,@MNUM ST @FAC1,@YPT Set row pointer XML SPEED Get column value BYTE PARCOM * and insure a comma XML SPEED Insure in range BYTE RANGE * of 1 to 32 BYTE 1 DATA 32 DEC @FAC1 Internal range: 0 - 31 ST @FAC1,@XPT Set column pointer RTN * Subroutine to control border color * Character background is also affected since transparent * is used. BORDER CALL PARFF Insure '(' , and parse CALL RAN16 Check 1 - 16 & put in interna MOVE 1,@FAC1,#7 Load VDP register BR LNKRT2 Return to XB program * Get ROW, COLUMN VALUES AND NUMBER OF CHARACTERS HVCHR CALL GPHV Get X, Y VALUES XML PARSE BYTE RPARZ CALL INTARG ADD OFFSET,@FAC1 ST @FAC1,@VAR0 SAVE THE CHARACTER DST 1,@FAC ASSUME 1 CHARACTER CEQ RPARZ,@CHAT If not right parenthesis BS GAC95 XML SPEED Must be BYTE SYNCHK * at a BYTE COMMAZ * comma XML PARSE # OF CHARACTERS BYTE RPARZ CALL INTARG FLOATING TO INTEGER GAC95 RTN *********************************************************** * ERRWXY - Is the subroutine for CALL ERR(W,X,Y,Z) * The parameters indicate: * W - The error code # of the error * X - Indicates whether execution(-1) error or * I/O (0-255) error on LUNO 0-255 * Y - Indicates the severity code of the error * Z - Line number of the error * ERR Can be called with 2 forms: * CALL ERR(W,X,Y,Z) and CALL ERR(W,X) * If ERR is called and no error has occured then all * values returned are zero. *********************************************************** ERRWXY DST @VSPTR,@FAC8 Get a temp VSPTR GAC99 DCH @STVSPT,@FAC8 While not a bottom of stack BR GACD0 ST V@2(@FAC8),@ARG Keep ID code in ARG area CEQ >69,@ARG *** ERROR entry BR GACAF CALL SQUISH Squish it out of the stack XML VPUSH Put permanent copy of error * entry on stack BR ERR10 Jump out now * Jump always GACAF CEQ >67,@ARG *** FOR entry BR GACBA DSUB 32,@FAC8 Skip it BR GACCE GACBA CEQ >66,@ARG *** GOSUB entry BR GACC5 DSUB 8,@FAC8 Skip it BR GACCE GACC5 CEQ >6A,@ARG * SYNTAX ERROR BR ERRSYN DSUB 16,@FAC8 Skip it GACCE BR GAC99 GACD0 DST >0080,@FAC No error entry there so DST >6900,@FAC2 fake one DCLR @FAC4 DCLR @FAC6 ERR10 XML VPUSH Push the temporary entry on * top of stack * Code to get "W" in CALL COMB Check for left parenthesis CALL ERRC05 Pick up user's symbol ST V@-8(@VSPTR),@FAC1 Get error code XML CIF Convert it to floating XML ASSGNV Assign it * Code to get "X" in CALL ERRCOM Check syntax & get user's sym CLOG >80,V@-7(@VSPTR) If execution BR GAD03 MOVE 8,G@FLT1,@FAC Make it such DNEG @FAC Make it a negative BR GAD0B GAD03 ST V@-5(@VSPTR),@FAC1 Get I/O LUNO number XML CIF Convert it to floating GAD0B XML ASSGNV * Code to get "Y" in CEQ RPARZ,@CHAT If long form of CALL ERR BS GAD42 CALL ERRCOM Check syntax & get user's sym ST V@-7(@VSPTR),@FAC1 Get severity code AND >7F,@FAC1 Reset execution / I/O flag XML CIF Convert it XML ASSGNV Assign it * Code to get "Z" in CALL ERRCOM Check syntax & get symbol DST V@-2(@VSPTR),@FAC2 Get line pointer DST @FAC2,@FAC DCZ @FAC2 If line number exists BS GAD3E DDECT @FAC2 Point to the line # CALL GRSUB1 Read line # (2 bytes) from VD * or ERAM (use GREAD) BYTE >4C * @FAC2: Source addr on ERAM/VD DST @EEE,@FAC Put the line # in FAC AND >7F,@FAC Reset the breakpoint if any GAD3E XML CIF Convert it XML ASSGNV Assign it GAD42 XML VPOP Trash the temporary entry B LNKRTN Return from subprogram * Must be long branch because of AND above ERRCOM CEQ COMMAZ,@CHAT Check for comma BR ERRSYN ERRC05 XML PGMCHR Get the next character XML SYM Collect name & s.t. entry XML SMB Get value space XML VPUSH Push it CLR @FAC Set up for conversion RTN * CHANGE IN ADDRESS OF THE ERROR CALLS WILL AFFECT * THE FILE SUBS..... * ERROR messages called from this file ERRSYN CALL ERRZZ * SYNTAX ERROR BYTE 3 * (shared by SUBS) ERRSNM CALL ERRZZ * STRING-NUMBER MISMATCH BYTE 7 * (shared by SUBS) ERRMUV CALL ERRZZ * IMPROPERLY USED NAME BYTE 9 ERRMEM CALL ERRZZ * MEMORY FULL BYTE 11 ERRSO CALL ERRZZ * STACK OVERFLOW BYTE 12 ERRNWF CALL ERRZZ * NEXT WITHOUT FOR BYTE 13 ERRFNN CALL ERRZZ * FOR/NEXT NESTING BYTE 14 ERRSNS CALL ERRZZ * MUST BE IN SUBPROGRAM BYTE 15 ERRRSC CALL ERRZZ * RECURSIVE SUBPROGRAM CALL BYTE 16 ERRRWG CALL ERRZZ * RETURN WITHOUT GOSUB BYTE 18 ERRBS CALL ERRZZ * BAD SUBSCRIPT BYTE 20 ERRLNF CALL ERRZZ * LINE NOT FOUND BYTE 22 ERRBA CALL ERRZZ * BAD ARGUMENTS BYTE 28 ERRBV CALL ERRZZ * BAD VALUE BYTE 30 * (shared by SUBS) ERRIAL CALL ERRZZ * INCORRECT ARGUMENT LIST BYTE 31 * (shared by SUBS) ERRSNF CALL ERRZZ * SUBPROGRAM NOT FOUND BYTE 37 * Other error messages appear in this program * ERRRDY * READY DATA 0 * ERRBRK * BREAK POINT DATA 1 * ERROLP * ONLY LEGAL IN A PROGRAM DATA 27 * * WRNN01 * NUMERIC OVERFLOW DATA 2 * WRNS02 * WRNST1 * STRING TRUNCATED DATA 19 * WRNST2 * WRNLNF * LINE NOT FOUND DATA 38 * *********************************************************** * SPRITE SUBROUTINES BRANCH TABLE CHAR1 BR SPNUM3 Called in CHARLY. EXEC CHAR2 BR SPNUM2 Called in CHARLY. EXEC BR $ Called in CHARLY. EXEC * SUBROUTINE LINK LIST LINKS1 DATA LINKS2 STRI 'SPRITE' SPRITE DATA SPRTE LINKS2 DATA LINKS3 STRI 'DELSPRITE' DELSPRITE DATA SPRDEL LINKS3 DATA LINKS4 STRI 'POSITION' POSITION DATA SPRPOS LINKS4 DATA LINKS5 STRI 'COINC' CONIC DATA ZSCOI LINKS5 DATA LINKS6 STRI 'MAGNIFY' MAGNIFY DATA SPRMAG LINKS6 DATA LINKS7 STRI 'MOTION' MOTION DATA SPRMOV LINKS7 DATA LINKS8 STRI 'LOCATE' LOCATE DATA SPRLOC LINKS8 DATA LINKS9 STRI 'PATTERN' PATTERN DATA SPRPAT LINKS9 DATA LINKSA STRI 'DISTANCE' DISTANCE DATA ZSDIST LINKSA DATA LINKSB STRI 'SAY' SAY DATA SAY LINKSB DATA LINKSC STRI 'SPGET' SPGET DATA SPGET LINKSC DATA LINKSD STRI 'CHARSET' CHARSET DATA CHRSET LINKSD DATA LINKSE STRI 'ONKEY' ONKEY DATA ZONKEY LINKSE DATA LINKSF STRI 'MOVES' MOVES DATA MOVES LINKSF DATA LINKSG STRI 'HPUT' HPUT DATA HPUT LINKSG DATA LINKSH STRI 'VPUT' VPUT DATA VPUT LINKSH DATA LINKSI STRI 'HGET' HGET DATA HGET LINKSI DATA LINKSJ STRI 'VGET' VGET DATA VGET LINKSJ DATA LINKSK STRI 'EXECUTE' EXECUTE DATA EXECUT LINKSK DATA LINKSL STRI 'GMOTION' GMOTION DATA GMOT LINKSL DATA LINKSM STRI 'RMOTION' RMOTION DATA RMOT LINKSM DATA LINKSN STRI 'HEX' HEX DATA HEX LINKSN DATA LINKSO STRI 'IO' IO DATA RXBIO LINKSO DATA LINKSP STRI 'INVERSE' INVERSE DATA INV LINKSP DATA LINKSQ STRI 'SWAPCHAR' SWPCHAR DATA SWCHR LINKSQ DATA LINKSR STRI 'DUPCHAR' DUPCHAR DATA DUPCHR LINKSR DATA LINKSS STRI 'SWAPCOLOR' SWAPCOLOR DATA SWCLR LINKSS DATA LINKST STRI 'DUPCOLOR' DUPCOLOR DATA DUPCLR *********************************************************** * CALL SPRITE(#SPRITE,CHAR,COLOR,Y,X,(YSPEED,XSPEED),...) *********************************************************** SPRTE CALL SPNUM1 Check sprite mode and skip "( CALL SPNUM2 Get sprite number SPRT3 CALL SPCHR Put character number for spri XML SPEED BYTE SYNCHK BYTE COMMAZ * Check for comma and skip it CALL GA01E Put sprite color in SAL (SPC XML SPEED Insure at a comma BYTE SYNCHK BYTE COMMAZ CALL SPLOC Put location of sprite in SAL DST @SP04+1,V*SPSAL Put in location of sprite * Finish defining SAL. Check if velocity is specified SPRT4 CEQ COMMAZ,@CHAT Finished!!!!! BR GB0F2 XML PGMCHR CEQ NUMBEZ,@CHAT Next sprite specified BR GAEBB CALL SPNUM3 Get the next sprite number BR SPRT3 And go! GAEBB CALL SPMOVE Get the velocity first BR SPRT4 *********************************************************** * CALL DELSPRITE(#SPR,.......) or CALL DESPRITE(ALL) *********************************************************** SPRDEL CALL SPNUM1 Insure at '(' SPDEL1 XML PGMCHR Skip "(" or "," CEQ NUMBEZ,@CHAT If sprite number BR GAEF6 XML PGMCHR Skip "#" XML PARSE Parse the sprite number BYTE RPARZ CALL SPNUM4 Check and convert number DCLR V@>0480(@SPSAL) Stop motion if moving DST >C000,V*SPSAL Hide the sprite off screen *---------------------------------------------------------- * Add following 7 lines for speeding up XBASIC CEQ @MOTION,V@SPNUM Check current sprite BR SPDEL2 * no. against sprite motion count * yes, change to as low as possible GAEE1 DEC @MOTION BS SPDEL2 DSUB 4,@SPSAL DCZ V@>0480(@SPSAL) BS GAEE1 *---------------------------------------------------------- SPDEL2 CEQ COMMAZ,@CHAT If more sprites BS SPDEL1 BR GAEFD GAEF6 XML SPEED Must have 'ALL' else error BYTE SYNCHK BYTE ALLZ CALL SPRINT Reinitialize all sprites GAEFD BR GB0F2 Return to caller *********************************************************** * CALL POSTION(#SPR,Y,X,...) *********************************************************** SPRPOS CALL SPNUM1 Check for sprites and skip "( SPRP02 CALL SPNUM2 Check sprite number CALL PREPN Prepare Y-position return var XML SPEED Insure at a comma BYTE SYNCHK BYTE COMMAZ DST V*SPSAL,@SP00 Read X, Y position ST @SP00,@FAC1 Get Y position CEQ >FE,@FAC1 BR GAF1C DINCT @FAC Get 256 as an output BR GAF1E GAF1C INCT @FAC1 Regular adjustment for user GAF1E CALL SPRP03 Check, convert & assign value CALL PREPN Prepare X-pos return variable ST @SP00+1,@FAC1 Get X position DINC @FAC Adjust for the user CALL SPRP03 Check, convert & assign value CEQ COMMAZ,@CHAT If not finished BS SPRP02 BR GB0F2 Return SPRP03 XML CIF Convert integer to float DCEQ >C000,@SP00 If hidden sprite BR GAF3D DCLR @FAC Return value zero GAF3D XML ASSGNV Assign to variable RTN *********************************************************** * CALL COINC(#SPR,#SPR,TOLERANCE,CODE) * CALL COINC(#SPR,YLOC,XLOC,TOLERANCE,CODE) * CALL COINC(ALL) *********************************************************** SPRCOI CALL SPNUM1 XML PGMCHR Skip "(" CEQ ALLZ,@CHAT Check coinc of all sprites BR GAF56 XML PGMCHR Skip "ALL" CALL COMMA2 Check and skip "," CLOG >20,@VDPSTT Check VDP status * RXB PATCH CODE ************ * BS NULRTN BS NR BR GAF6C * RXB PATCH CODE ************ GAF56 CALL CODIST Get distance of 2 sprites CALL COMMA Get tolerance level XML SPEED BYTE RANGE * Check against range BYTE 0 * FAC has tolerance level DATA 255 DCH @FAC,@SP00 Y-loc out of range * RXB PATCH CODE ************ * BS NULRTN BS NR DCH @FAC,@SP04 X-loc out of range * RXB PATCH CODE ************ * BS NULRTN BS NR * If no conincidence just return zero GAF6C CALL PREPN Prepare for numeric output DST >BFFF,@FAC Store -1 in FAC * RXB PATCH CODE ************ * BR ASSRTN BR AR *********************************************************** * CALL MAGNIFY(magnification factor=1 - 4) *********************************************************** SPRMAG CALL SPNUM1 Insure at "(" XML PGMCHR Skip the "(" XML PARSE Parse the magnification facto BYTE RPARZ XML SPEED BYTE RANGE BYTE 1 DATA 4 * Next statement adding >DF to subtract 1 from FAC ADD >DF,@FAC1 Turn on screen and interrupt MOVE 1,@FAC1,#1 Store it to VDP register 1 BR GB0F2 *********************************************************** * CALL MOTION(#SPR,YSPEED,XSPEED,...) *********************************************************** SPRMOV CALL SPNUM1 Insure at "(" * RXB PATCH CODE ************* * SPRMV2 CALL SPNUM2 Get sprite number SPRMV2 B SPGS GO or STOP SPRMV3 CALL SPMOVE Store velocity SPRMV4 CEQ COMMAZ,@CHAT Loop if more BS SPRMV2 BR GB0F2 *********************************************************** * CALL LOCATE(#SPR,YLOC,XLOC,...) *********************************************************** SPRLOC CALL SPNUM1 Insure at "(" SPRLC2 CALL SPNUM2 Check sprite number CALL SPLOC Read location DST @SP04+1,V*SPSAL Put in sprite location CEQ COMMAZ,@CHAT Loop if more BS SPRLC2 BR GB0F2 *********************************************************** * CALL PATTERN(#SPR,CHAR,...) *********************************************************** SPRPAT CALL SPNUM1 Insure at "(" SPRPT2 CALL SPNUM2 Get sprite number CALL SPCHR Set the sprite character CEQ COMMAZ,@CHAT Loop if more BS SPRPT2 BR GB0F2 *********************************************************** * CALL DISTANCE(#1,#2,DISTANCE) * CALL DISTANCE(#1,Y,X,DISTANCE) *********************************************************** DIST CALL SPNUM1 Insure at "(" * RXB PATCH LABEL ************ GAFC4 XML PGMCHR Skip "(" CALL CODIST Get distance in Y and X CALL PREPN Prepare return variable DMUL @SP00,@SP00 X=X*X DMUL @SP04,@SP04 Y=Y*Y DADD @SP06,@SP02 @SP02=X*X+Y*Y OVF Checking overflow bit BS OVER If overflow-indicate maximum DST @SP02,@FAC Put distance squared in FAC DCH >7FFF,@SP02 If bigger then 128 BR GAFE5 OVER DST >7FFF,@FAC Put maximum value GAFE5 XML CIF Convert to floating format * RXB PATCH CODE * BR ASSRTN Assign value and return BR AR *********************************************************** * CODIST routine gets locations of two sprites or one * sprite and Y and X position specified by a user and * calculates absolute value of Y and X distance. *********************************************************** CODIST CLR @SP00 MOVE 7,@SP00,@SP00+1 Clear up first 8 bytes CEQ NUMBEZ,@CHAT Check for # BR ERRSYN CALL SPNUM3 Get the first sprite DST V*SPSAL,@SP00+1 Location of first sprite INC @SP00+1 Increment to make range 1-256 ST @SP02,@SP02+1 Put X in SP02+1 CLR @SP02 Y in SP00+1 CEQ NUMBEZ,@CHAT Get 2nd sprite BR GB011 CALL SPNUM3 Get the next sprite DST V*SPSAL,@SP04+1 Location of second sprite BR GB017 GB011 CALL SPLOC Get Y and X location CALL COMMA2 Check for comma and skip GB017 INC @SP04+1 Increment to make range 1-256 DSUB @SP04,@SP00 Difference in Y at SP00 DABS @SP00 Get absolute value CLR @SP04+1 Clear byte before X DSUB @SP02,@SP04+1 Difference in Y at SP04 DABS @SP04+1 get the absolute value ST @SP06,@SP04+1 Put in the right place RTN *********************************************************** * CHRSET restores the standard character set and the * standard colors for the standard character set * (black on transparent) *********************************************************** CHRSET CALL CHKEND Must be at EOS now BR ERRSYN Else its an erro ST 94,@FAC2 Number of characters CLR V@>03F8 EDGE CHAR ADDRESS MOVE 896,V@>03F8,V@>03F9 Clear bytes DST >0408,@FAC Start with ! DST CHARS,@FAC4 GROM ADDRESS CHRLP MOVE 7,G@0(@FAC4),V@1(@FAC) Get GROM Def DADD 8,@FAC GROM ADDRESS DADD 7,@FAC4 VDP ADDRESS DEC @FAC2 Character Count-1 BR CHRLP 0? ST >10,V@>080F Set 1st set to black on tranp MOVE 16,V@>080F,V@>0810 Ripple for res CALL RETURN Return to the caller ****************************** * SPNUM1 ROUTINE * ****************************** SPNUM1 CEQ LPARZ,@CHAT Should be "(" BR ERRSYN RTN ****************************** * SPNUM2 ROUTINE * ****************************** SPNUM2 XML PGMCHR Get the next character SPNUM6 CEQ NUMBEZ,@CHAT Must be "#" BR ERRSYN SPNUM3 XML PGMCHR Get next character CALL COMMA Parse up to comma and skip it SPNUM4 XML SPEED BYTE RANGE * Verify the value is in range BYTE 1 * Sprite number 1 - 28 DATA 28 *---------------------------------------------------------- * Insert a line here in sprite handling code for speeeding * up XB 5/22/81 * RXB PATCH LABLE ************ SPNUM5 ST @FAC1,V@SPNUM Keep sprite number *---------------------------------------------------------- DEC @FAC1 Adjust for internal use DSLL 2,@FAC Get location of SAL DADD >0300,@FAC Sprite # * 4 + >0300 DST @FAC,@SPSAL Save SAL location RTN ****************************** * SPLOC ROUTINE * ****************************** SPLOC CALL COMMA Parse up to comma and skip it XML SPEED BYTE RANGE * Range of Y: 1 - 256 BYTE 1 DATA 256 DECT @FAC1 Adjust for internal use: FF - DST @FAC,@SP04 Store in SP04 area XML PARSE BYTE RPARZ * Parse to ")" or less XML SPEED BYTE RANGE * Get X value. Range: 1 - 256 BYTE 1 DATA 256 DEC @FAC1 Adjust for internal use: 0 - ST @FAC1,@SP06 SP04+1=Y-loc and SP06=X-loc RTN ****************************** * SPCHR ROUTINE * ****************************** SPCHR XML PARSE BYTE RPARZ XML SPEED BYTE RANGE * Check upper range * RXB PATCH CODE * BYTE 32 * Character value 32 - 144 * DATA 143 BYTE 30 DATA 159 ADD >60,@FAC1 Add offset to character numbe ST @FAC1,V@2(@SPSAL) Store the character value RTN ****************************** * SPMOVE ROUTINE * ****************************** SPMOVE CALL COMMA Parse up to comma and skip CALL RANGEV Check if numeric and convert * to integer ST @FAC1,@SPTMP Store Y velocity XML PARSE Get X velocity BYTE RPARZ * Check for ")" or less CALL RANGEV Numeric check and convert * to integer SPMOVF ST @SPTMP,@FAC * @FAC=Y velocity, @FAC1=X velo DST @FAC,V@>0480(@SPSAL) Store velocities in SAL *---------------------------------------------------------- * Add the following 3 lines for speeding up XB CH @MOTION,V@SPNUM Check current sprite BR GB0BD against sprite motion * counter ST V@SPNUM,@MOTION higher? Yes, replace it *---------------------------------------------------------- GB0BD RTN RANGEV CH >63,@FAC2 The same as INTARG BS ERRSNM CLR @FAC10 DCLR @FPERAD XML FLTINT CZ @FAC10 BR ERRBV DCGE 0,@FAC If positive number, BR GB0DB DCH >007F,@FAC should be 0 - 127 BS ERRBV BR GB0E1 If negative number, GB0DB DCHE >FF80,@FAC Should be -1 to -128 BR ERRBV GB0E1 RTN Otherwise its ok. ****************************** * COMMA ROUTINE * ****************************** COMMA XML PARSE BYTE COMMAZ COMMA2 CEQ COMMAZ,@CHAT BR ERRSYN XML PGMCHR Get next character RTN ****************************** * LINK BACK TO XB * ****************************** NULRTN CALL PREPN ASSRTN XML ASSGNV GB0F2 B GA01C (LNKRTN) ******************************* * PREPARE FOR PASSING ARGUMENT* ******************************* PREPN XML SYM Pick up name & search table XML SMB Evaluate any subscripts CH >63,@FAC2 If not numeric, error BS ERRIAL XML VPUSH Save entry on stack CLR @FAC Clear FAC for new value MOVE 7,@FAC,@FAC1 RTN *********************************************************** * CALL SAY(....................) * Decode given parameter(s). Store all data first, then go * speak it all at once. *********************************************************** SAY CEQ LPARZ,@CHAT Must start with "(" BR ERRSYN DST @VSPTR,@FAC2 Save current top of stack on XML VPUSH the stack DST 255,@BYTES 255 bytes = 85 3 byte entires XML GETSTR Get temp speech list string DST >001C,@FAC Indicate it is temp string (S DST >6500,@FAC2 Indicate it is string entry DST @SREF,@FAC4 Save pointer to temp string DST @BYTES,@FAC6 Length is 255 XML VPUSH Make it semi-permenant * Set up pointers into the speak list DST @FAC4,@PTFBSL Front points to begining DST @FAC4,@PTLBSL Last now points to beginning DST @PTFBSL,@PTEBSL DADD @FAC6,@PTEBSL End points to the end+1 CALL SETRW Set PHROM read/write address CALL WAIT Wait till no one is speaking DIRSPK CALL GETPRM Get next parameter BS NEXT1 If non-null ASCII string DST @FAC4,@PTFCIS Set up pointer to first char DST @FAC6,@PTLCIS Set ptr-to-last-char-in-strin DADD @PTFCIS,@PTLCIS by adding length-of-string DDEC @PTLCIS and subtracting 1 * Make a speech list CALL SETRW Set speech read/write addrs DST @PTFCIS,@PTCCIS Start at beginning of string CLR @TOTTIM Clear total time delay CALL GETTIM Get first timing mark CALL TIMING Get any subsequent marks * The total first time delay is in TOTTIM now GB158 DCH @PTLCIS,@PTCCIS While more string BS GB1A7 CALL PHRASE Get next phrase * If spell flag is 0, try to look the phrase up. If it * can not be found, then set the spell flag, and it will be * spelled out. If found, save on speak list. CZ @SPLFLG There is a phrase BR GB173 CALL LOOKUP Try to look it up in the PHRO DCZ @DATAAD If not found then BR GB170 ST 1,@SPLFLG Set the spell flag BR GB173 GB170 CALL STDATA Store data in list * If spell flag is 1, set time delay to >3C, and take the * phrase one character at a time (spell it). Look up each * character: if not found, use 'UHOH' data instead. * Regardless, store data on speak list. GB173 CEQ 1,@SPLFLG Need to spell it out? BR GB1A0 DST @PTLCIP,@PTLCIL Est last char to spell out ST >3C,@TOTTIM >3C used because sounds good * Take each single character * Skip over any embedded spaces encountered in a phrase GB17E CEQ SPACE,V*PTFCIP BR GB188 DINC @PTFCIP BR GB17E * Set first and last pointers to same one character GB188 DST @PTFCIP,@PTLCIP CALL LOOKUP Try to look it up * If not found, use data to 'UHOH' DCZ @DATAAD BR GB196 DST >71F4,@DATAAD Put addr of 'UHOH' in GB196 CALL STDATA Store data on speak list DINC @PTFCIP Go on to next character DCH @PTLCIL,@PTFCIP Until done all BR GB17E * At this point, get next timing group. The first timing * character has already been found, and it's value is still * in TIMLEN. Therefore, initiatory call to GETTIM not * needed. Simply clear TOTTIM and call TIMING. GB1A0 CLR @TOTTIM CALL TIMING BR GB158 * At this point, finished all the phrases in this string. * TOTTIM should equal >FE, it indicate end of sting If it * doesn't equal >FE, it indicates that a timing group was * put on the end of the string. Therefore, save the timing * group with a null data address to show it is only timing. GB1A7 CEQ >FE,@TOTTIM BS NEXT1 DCLR @DATAAD CALL STDATA * Next item could be direct string. NEXT1 CEQ COMMAZ,@CHAT If direct string present BR SPEAK CALL GETPRM Get the next parameter BS NEXT2 If non-null direct string ST >FF,@TOTTIM Mark TOTTIM as direct string XML VPUSH Save direct string on stack DST @VSPTR,@DATAAD Store stack addr on string CALL STDATA And add to the speak list * If the next character is a comma, loop thru it again NEXT2 CEQ COMMAZ,@CHAT BS DIRSPK * If end fall into SPEAK *********************************************************** * SPEAK will actually speak the speech list. It tests the * timing byte to see if it is an >FF. If it is, then the * data following it points to a direct speech data string * in VDP. If it is not, then the data following it points * to a PHROM speech data list. In the first case, this * routine will issue a speak external command to the PHROM * and then feed bytes out to the PHROM as it requests them. * In the second case, the address will be loaded out to the * PHROM, and then a speak command will be issued. *********************************************************** SPEAK CALL SETRW Set read/write address GB1CE DCHE @PTLBSL,@PTFBSL More speech list to go BS GB258 CALL WAIT Yes, wait until previous * speech is though CEQ >FF,V*PTFBSL External speech data BS GB1FE ST V*PTFBSL,@TIMER No, load timer NEG @TIMER and neg it to correct DST V@1(@PTFBSL),@PTFBPH Put addr into PTFBPH DADD 3,@PTFBSL and skip to next node LOOP1 CGE 0,@TIMER Wait for time delay BR LOOP1 CZ @PTFBPH If there is data BS GB1FC CALL LOADAD Load the addr to PHROM ST >50,@VAR0(@WRITE) and issue speak command GB1FC BR CONTIN GB1FE DINC @PTFBSL Speak external, skip over >FF DST V*PTFBSL,@PTCBED Set up pointer to 1st byte DST V@4(@PTCBED),@PTCBED in external speech data DINCT @PTFBSL Skip addr bytes ST V@-1(@PTCBED),@LENWST Get Len of whole string DIRSPH SUB 3,@LENWST Minus 3 bytes overhead * All external speech strings start with a >60 CEQ >60,V*PTCBED Bad speech string BR ERRBV CALL WAIT Wait for go ahead DINCT @PTCBED Skip spk ext & 1st byte len ST V*PTCBED,@LENCST Get len of current string DINC @PTCBED Skip len byte to 1st real byt ST 16,@TEMP2 Do 1st 16 bytes (fill buff) ST >60,@VAR0(@WRITE) Start Speak External LOOPR ST V*PTCBED,@VAR0(@WRITE) Write byte to PHROM DINC @PTCBED Go to next byte DEC @LENWST 1 less char in whole string BS CONTIN Finished whole string? DEC @LENCST 1 less char in curr string BS DIRSPH Finished current string? DEC @TEMP2 1 less char in this loop BR LOOPR Not finished curr loop yet? GB241 ST @VAR0(@READ),@SPKSTS Read status from PHROM * If the next statement is true, it means that speak was * probably interupted and that it is shot at this point. * Therefore, we are going to quit now. CLOG >80,@SPKSTS BS CONTIN CLOG >40,@SPKSTS Loop till buff below half BS GB241 ST 8,@TEMP2 Put 8 more bytes to PHROM BR LOOPR and go do these CONTIN B GB1CE We've said it all!! * Now pop all entries off stack that we put on! GB258 XML VPOP Free up a temporary string DCEQ @FAC2,@VSPTR BR GB258 BR GB0F2 And return to the caller *********************************************************** * SPGET subprogram. Load speech data from external device. * Use standard file I/O *********************************************************** SPGET CEQ LPARZ,@CHAT Must have left parenthesis BR ERRSYN CALL SETRW Set PHROM read/write address CALL WAIT Wait till no one is speaking NXTPAR CALL GETPRM Get the next parameter DCZ @FAC6 If non-null ASCII string BS GB318 DST @FAC4,@PTFCIS Pointer to 1st char in string DST @FAC6,@PTLCIS Pointer to last-char-in-strin DADD @PTFCIS,@PTLCIS by adding length-of-string DDEC @PTLCIS and subtracting 1 CALL SETRW Set the speech read/write add DST @PTFCIS,@PTCCIS Set curr char to first char CLR @TOTTIM Clear total time delay CALL GETTIM Get first timing mark CALL TIMING Get any subsquent marks * Get one phrase, and look it up. If the phrase is not foun * substitute in 'UHOH'. DCH @PTLCIS,@PTCCIS Possible phrase BS GB318 CALL PHRASE Yes, go get it CEQ 1,@SPLFLG Spell flag set then set BR GB29C DST @PTFCIP,@PTLCIP last ptr to first (1 char) GB29C CALL LOOKUP Look up the phrase DCZ @DATAAD If not there, BR GB2AA DST >71F4,@DATAAD use 'UHOH' data addr ST >51,@STRLEN 'UHOH' data length * Data must be in PHRADD and PHLEN, so move it GB2AA DST @DATAAD,@PHRADD ST @STRLEN,@PHLEN ADD 3,@PHLEN For overhead info * There must be a variable to put this data in. If not, err XML SPEED BYTE SYNCHK BYTE COMMAZ XML SYM Find symbol in table XML SMB Evaluate andy subscripts XML VPUSH Save for assignment CLR @BYTES Two byte value ST @PHLEN,@BYTES+1 Length of string needed XML GETSTR Get a string for the data CALL SETRW Set up speech read/write addr DST >001C,@FAC Now build string FAC entry DST >6500,@FAC2 String ID DST @SREF,@FAC4 Pointer to string DST @BYTES,@FAC6 Length of string DST >6000,V*SREF Mark string as speech data ST @PHLEN,V@2(@SREF) Put in string length DSUB 3,V@1(@SREF) minus thei info * LOADAD expects addr to be in PTFBPH, so move it. DST @PHRADD,@PTFBPH CALL LOADAD * Going to copy string from PHROM to VDP. The actual data * from PHROM is in bit-reversed order, so must reverse the * order after reading in the order. Remember that 3 bytes * PHLEN are our own overhead, so don't copy all GB2EB CH 3,@PHLEN BR GB316 ST >10,@VAR0(@WRITE) Issue read byte command ST @VAR0(@READ),@BYTE3 Read the byte * the following code is somewhat tricky. It will bit * reverse the contents of BYTE3 into BYTE1 through * BYTE2 by means of word shifts. Note the definition of * BYTE1 , BYTE2, and BYTE3 in EQU's. You might try an * example if it isn't clear what is going on. CLR @BYTE2 ST >08,@TEMP1 RNDAG DSRC 1,@BYTE2 DSLL 1,@BYTE1 DEC @TEMP1 BR RNDAG * Store the bit-corrected byte into the string & inc str pt ST @BYTE1,V@3(@SREF) DINC @SREF DEC @PHLEN Dec the string length BR GB2EB Go do next char if there is o GB316 XML ASSGNV Assign the string to variable GB318 CEQ COMMAZ,@CHAT If more go do BS NXTPAR BR GB0F2 *********************************************************** * GETPAM gets the next string paameter passed to the * routine. If that parameter is non-exist or null, then * condition bit is set. If the parameter is there then * condition bit is reset and the FAC entry describes the * string. In either case, return with condition is done. *********************************************************** GETPRM XML PGMCHR Get next token CEQ COMMAZ,@CHAT Go set condition no parm BS SETCB XML PARSE BYTE RPARZ CEQ >65,@FAC2 If not string, error BR ERRSNM DCZ @FAC6 Set cond if null string RTNC Else return SETCB CEQ @VAR0,@VAR0 Set condition bit RTNC *********************************************************** * Get the next phrase out of the current string. The phrase * may begin with a #, which means it will continue to the * next #, or it many begin with an ordinary character, in * which case it will end with the character just before the * first timing character encountered. In either case, the * end of the string will indicate a legal end of phrase if * it occurs before the usual indicator! *********************************************************** PHRASE CEQ NUMBER,@CCHAR Phrase start with #? BR GB370 DINC @PTCCIS Yes, inc CC ptr past # GB33C CEQ SPACE,V*PTCCIS Skip spaces BR GB346 DINC @PTCCIS BR GB33C GB346 CEQ NUMBER,V*PTCCIS All spaces? BR GB34F DINC @PTCCIS Yes, skip this # too RTN And ignore this phrase GB34F DST @PTCCIS,@PTFCIP Save 1st char in phrase GB352 DINC @PTCCIS Go on to next char * Got to watch for end of string. If encountered before a * #, act like char after string is #. Then last char will * be char before, or the last char in the string!! DCH @PTLCIS,@PTCCIS BS FNDNUM ST V*PTCCIS,@CCHAR No, get char in CCHAR CEQ NUMBER,@CCHAR If not # continue looking BR GB352 FNDNUM DST @PTCCIS,@PTLCIP Last char in phrase is one DDEC @PTLCIP before the # DINC @PTCCIS Point to char after # CALL GETTIM Get 1st timing char after phr CLR @SPLFLG Indicate don't spell BR GB38B No # as 1st char in phrase GB370 DST @PTCCIS,@PTFCIP Curr char is 1st char phrase CLR @SPLFLG Assume don't spell CHE >41,@CCHAR If not alphabetic (>41="A") BS GB37C INC @SPLFLG set spell flag * Need to find end of phrase, which is char before next * timing char we find. Therefore, look for a timing char! GB37C DINC @PTCCIS CALL GETTIM CEQ >FF,@TIMLEN If not timing, loop BS GB37C DST @PTCCIS,@PTLCIP Char before curr char is DDEC @PTLCIP the last char in phrase GB38B RTN *********************************************************** * TIMING will loop through chars in string until it finds * non-timing char. Non-timing chars have TIMLEN values of * >FE or >FF. GETTIM must be called before this routine to * establish a correct value of TIMLEN. Also, most likely * TOTTIM should have been cleared. *********************************************************** TIMING CHE >FE,@TIMLEN BS GB39B DADD @TIMLEN,@TOTTIM DINC @PTCCIS CALL GETTIM BR TIMING GB39B RTN *********************************************************** * GETTIM will examine the current char in the string and * set TIMLEN to the appropriate time delay value. TIMLEN * can take on the following values: * >00 if char is timing '+' * >06 if char is timing ' ' * >0C if char is timing '-' * >12 if char is timing ',' * >1E if char is timing ';' * >30 if char is timing ':' * >3C if char is timing '.' * >FE if char is out of stirng bounds * >FF if char is not timing * Note that to test timing, some manipulation of PTCCIS * would be neccesary, so it is stored and used in TEMP1 *********************************************************** GETTIM ST V*PTCCIS,@CCHAR Get the char DST @PTCCIS,@TEMP1 store curr ptr in TEMP1 DCH @PTLCIS,@TEMP1 out of string bounds? BR GB3AC ST >FE,@TIMLEN Yes, load value and return RTN GB3AC CH SEMICO,@CCHAR Can not be timing BS NOTIME CEQ SPACE,@CCHAR BR GB3C5 ST 6,@TIMLEN GB3B9 CEQ SPACE,V@1(@PTCCIS) While spaces BR GB3C4 DINC @PTCCIS Skip them BR GB3B9 GB3C4 RTN GB3C5 CEQ PLUS,@CCHAR BR GB3D4 DINC @TEMP1 Need to test the next char CALL NUMERC Is it numeric BS NOTIME Was numeric => not timing cha CLR @TIMLEN Not numeric => set as no timi RTN GB3D4 CEQ COMMAT,@CCHAR BR GB3DD ST >12,@TIMLEN RTN GB3DD CEQ PERIOD,@CCHAR BR GB3F4 DDEC @TEMP1 Go back to preceding char CALL NUMERC Is it numeric? BR PTIME No, so it is timing DINCT @TEMP1 Yes, on to following char CALL NUMERC Is it numeric too? BS NOTIME Yes, both numeric => not timi PTIME ST >3C,@TIMLEN Both not numeric => timing RTN GB3F4 CEQ HYPEN,@CCHAR BR GB404 DINC @TEMP1 Check next char CALL NUMERC Is it numeric? BS NOTIME Was numeric => not a timing c ST >0C,@TIMLEN Was not numeric => set as tim RTN GB404 CEQ COLON,@CCHAR BR GB40D ST >30,@TIMLEN RTN GB40D CEQ SEMICO,@CCHAR BR NOTIME ST >1E,@TIMLEN RTN NOTIME ST >FF,@TIMLEN Set as no timing char present RTN *********************************************************** * NUMERC tests the char pointed to by PTCCIS and verifies * the following: * 1 - it is within the current string boundaries * 2 - it is numeric (i.e. between '0' and '9') * If both of the above conditions are true, COND is set * upon return, otherwise COND is reset *********************************************************** NUMERC DCH @PTLCIS,@TEMP1 BS GB430 DCH @TEMP1,@PTFCIS BS GB430 CHE >30,V*TEMP1 BR GB430 CH >39,V*TEMP1 BR SETCB GB430 RTNC *********************************************************** * LOOKUP is a prolong routine to SEARCH. In each PHROM, * there may be 2 trees, one starting at >0000 and the other * at >8000. Either may or may not be present. Presences is * determined if a >AA byte is at the starting location. * LOOKUP determines if the tree at >0000 is in, and if so, * calls SEARCH with that addr. If that tree is not present * or the phrase couldn't be found in it, LOOKUP then checks * if the tree at >8000 is present, and again, if so, calls * SEARCH with that tree address. If the word was found in * the first tree, or after searching the second tree, the * routine will return. *********************************************************** LOOKUP DCLR @BYTE1 BYTE1 contains addr of curr t TRYAGN DST @BYTE1,@PTFBPH Look for >AA tree header CALL LOADAD LOADAD expects addr in PTFBPH ST >10,@VAR0(@WRITE) Put out read byte command CEQ >AA,@VAR0(@READ) Tree out there? BR GB44E DINC @PTFBPH Skip the tree header CALL SEARCH Go search this PHROM tree DCZ @DATAAD Phrase found => exit BR FOUND GB44E DADD >8000,@BYTE1 Go to start of next PHROM tre * Note >8000 + >8000 = >0000 => tried both trees DCZ @BYTE1 BR TRYAGN DCLR @DATAAD Didnt find phrase in either t FOUND RTN *********************************************************** * SEARCH actually searches the PHROM tree for the phrase. * The PHROM tree organization is as follows: * (i.e. this is one phrase node) * phrase ASCII length 1 byte * actual ASCII characters n bytes * less then pointer 2 bytes * greater then pointer 2 bytes * speech data pointer 3 bytes * speech data length 1 byte * The comparison of two words proceeds on a char by char * basis, where length is secondary to char values, i.e. * move > answer; number < we; eight < eighty; etc... *********************************************************** SEARCH CALL LOADAD Set PHROM to start phrase nod ST >10,@VAR0(@WRITE) Issue read byte command CLR @PTLCPH Length of phrase => PTLCPH ST @VAR0(@READ),@PTLCPH+1 (stored as 2 byte value DADD @PTFBPH,@PTLCPH Add front ptr giving end ptr DST @PTFBPH,@PTCCPH Set up curr char as 1 beyond DINC @PTCCPH length byte DST @PTFCIP,@PTCCIP Reset current ptr into phrase * Compare two characters NEXT ST >10,@VAR0(@WRITE) Issue read byte command ST @VAR0(@READ),@PHDATA Get char in from PHROM CEQ V*PTCCIP,@PHDATA Compare the char BR GB4D1 DINC @PTCCPH Equal, advance both pointers DINC @PTCCIP CEQ SPACE,V*PTCCIP Skip extra spaces BR GB4A1 GB48D CEQ SPACE,V@1(@PTCCIP) While spaces BR GB498 DINC @PTCCIP Skip them BR GB48D * By skipping extra spaces, might have reached end of phras * If this is true, next char in phrase = #. If so, advance * the pointer to be beyond end of phrase. GB498 CEQ NUMBER,V@1(@PTCCIP) BR GB4A1 DINC @PTCCIP GB4A1 DCH @PTLCPH,@PTCCPH End of PHROM word? BR GB4C6 DCH @PTLCIP,@PTCCIP Yes, end of phrase BR GB4C0 DST @PTLCPH,@PTFBPH Yes, word found * Skip 5 bytes down from last char to data pointer DADD 6,@PTFBPH CALL READAD Set data addr => DATAAD ST >10,@VAR0(@WRITE) Issue read byte command ST @VAR0(@READ),@STRLEN Get length of speech data RTN GB4C0 DST 3,@PTFBPH Move 3 bytes past PTLCPH BR NXTPHR GB4C6 DCH @PTLCIP,@PTCCIP 2 characters BR NEXT DST 1,@PTFBPH Phrase linger: use LT ptr BR NXTPHR * Two characters compared were not equal GB4D1 DST 3,@PTFBPH 3 bytes past last to GT CH V*PTCCIP,@PHDATA After phrase BR NXTPHR DDECT @PTFBPH Back up 2 bytes to LT link * Go get next phrase out of the PHROM to compare NXTPHR DADD @PTLCPH,@PTFBPH Add displacement to last char CALL READAD and get the new address DCZ @DATAAD More leaves on this tree BR GB4E8 RTN No, return empty handed GB4E8 DST @DATAAD,@PTFBPH Store new addr in PTFBPH BR SEARCH Go compare this new word! * The program should never reach this point!! It should * return somewhere up above. *********************************************************** * LOADAD will set the addr out in the PHROM to the addr * found in PTFBPH. Note that the PHROM is expecting five * nybbles to be written out as the address. *********************************************************** LOADAD DST @PTFBPH,@TEMP1 This is destructive, so copy DST @PTFBPH,@TEMP2 address into temporary areas SRL 4,@TEMP1 Isolate the MSN of the MSB SRL 4,@TEMP1+1 Isolate the MSN of the LSB DAND >0F0F,@TEMP2 Isolate the LSN of the MSB, L DOR >4040,@TEMP1 Include a 4 as MSN of all 4 n DOR >4040,@TEMP2 to indicate a Load Address C ST @TEMP2+1,@VAR0(@WRITE) Write out the LSN of th ST @TEMP1+1,@VAR0(@WRITE) Write out the LSN of th ST @TEMP2,@VAR0(@WRITE) Write out the MSN of th ST @TEMP1,@VAR0(@WRITE) Write out the MSN of th ST >40,@VAR0(@WRITE) Write out 0 as fifth ny RTN *********************************************************** * READAD will read an address from the PHROM and store it * in DATAAD. Note that PTFBPH should contain the addr of * the PHROM location to be read so LOADAD will work. *********************************************************** READAD CALL LOADAD Set the addr of the PHROM ST >10,@VAR0(@WRITE) Get high byte of addr ST @VAR0(@READ),@DATAAD Stroe it in DATAAD ST >10,@VAR0(@WRITE) Get low byte of addr ST @VAR0(@READ),@DATAAD+1 Store it in DATAAD+1 RTN *********************************************************** * STDATA will store the data in DATAAD and TOTTIM onto the * speech list. It will also check that there is room on the * speech list for this entry, and abort with error if not. *********************************************************** STDATA DCEQ @PTEBSL,@PTLBSL Is there room? BS ERRSSL MOVE 3,@TOTTIM,V*PTLBSL Put data in list DADD 3,@PTLBSL and inc top of list RTN *********************************************************** * WAIT loops until the speech peripheral goes idle. *********************************************************** * ( Loop until nobody is talking) WAIT ST @VAR0(@READ),@SPKSTS Read status from PHROM CLOG >80,@SPKSTS BR WAIT RTN *********************************************************** * SETRW moves addrs of speech read/write from GROM to VDP *********************************************************** SETRW MOVE 4,G@>0046,@READ RTN *********************************************************** * ERROR MESSAGES *********************************************************** * The following calls are in EXECS file. * ERRSYN CALL ERRZZ * SYNTAX ERROR * BYTE 3 * ERRSNM CALL ERRZZ * STRING-NUMBER MISMATCH * BYTE 7 * ERRBV CALL ERRZZ * BAD VALUE * BYTE 30 * ERRIAL CALL ERRZZ * INCORRECT ARGUMENT LIST * BYTE 31 *********************************************************** ERRSSL CALL ERRZZ * SPEECH STRING TOO LONG BYTE 21 *********************************************************** MOVES CALL SPNUM1 MOVES(TYPE$,BYTES,$,TO) * or MOVES(TYPE$,BYTES,FROM,$) MOVESA CALL STRGET * ( or , DST V*FAC4,@VAR5 * TYPE "VRG" CALL GETNUM * ,BYTES DCZ @FAC 0? BS ERRBV BAD VALUE DST @FAC,@BYTES SAVE NUMBER OF BYTES CALL STRFCH * ,FROM CEQ 36,@VAR5 BR MOVESX CHE @FAC6,@BYTES+1 BS MOVESB CLR @BYTES ST @FAC6,@BYTES+1 BR MOVESB MOVESX CALL CFIFCH DST @FAC,@FAC4 MOVESB DST @FAC4,@VARY CEQ 36,@VAR6 BR MOVESN DCHE 256,@BYTES BS ERRBV XML GETSTR CALL NGOOD DST @SREF,@FAC BR MOVESC MOVESN CALL SUBLP3 * ,TO MOVESC DST @FAC,@VARY2 CEQ 36,@VAR5 * VDP FROM BR MTYPES ST 86,@VAR5 MTYPES CEQ 36,@VAR6 BR MTYPE ST 86,@VAR6 MTYPE CEQ 86,@VAR5 * VDP FROM BR MTYPE3 CEQ 86,@VAR6 * VDP TO BR MTYPE1 MTYPE0 MOVE @BYTES,V@0(@VARY),V@0(@VARY2) MTYPE1 CEQ 82,@VAR6 * RAM TO BR MTYPE2 MOVE @BYTES,V@0(@VARY),@0(@VARY2) MTYPE2 CEQ 71,@VAR6 * GRAM TO BR MTYPE3 MOVE @BYTES,V@0(@VARY),G@0(@VARY2) MTYPE3 CEQ 82,@VAR5 * RAM FROM BR MTYPE7 CEQ 86,@VAR6 * VDP TO BR MTYPE5 MTYPE4 MOVE @BYTES,@0(@VARY),V@0(@VARY2) MTYPE5 CEQ 82,@VAR6 * RAM TO BR MTYPE6 MOVE @BYTES,@0(@VARY),@0(@VARY2) MTYPE6 CEQ 71,@VAR6 * GRAM TO BR MTYPE7 MOVE @BYTES,@0(@VARY),G@0(@VARY2) MTYPE7 CEQ 71,@VAR5 * GRAM FROM BR MOVESD CEQ 86,@VAR6 * VDP TO BR MTYPE9 MTYPE8 MOVE @BYTES,G@0(@VARY),V@0(@VARY2) MTYPE9 CEQ 82,@VAR6 * RAM TO BR MTYPEA MOVE @BYTES,G@0(@VARY),@0(@VARY2) MTYPEA CEQ 71,@VAR6 * GRAM TO BR MOVESD MOVE @BYTES,G@0(@VARY),G@0(@VARY2) MOVESD CEQ >B3,@CHAT BS MOVESA BR LNKRTN ****************************************************** * CALL HEX(variable,variabel,...) * ****************************************************** HEX CALL SPNUM1 HEXAGN CALL STRFCH Get STRING or NUMBER CEQ >65,@FAC2 STRING? BS HEXSTR Yes CALL CFIFCH No DST @FAC,@TEMP2 DST >0004,@BYTES XML GETSTR DST @SREF,@STRPTR ST @TEMP2,@VAR0 SRL 4,@VAR0 CALL HEXNS ST @TEMP2,@VAR0 SLL 4,@VAR0 SRL 4,@VAR0 CALL HEXNS ST @TEMP2+1,@VAR0 SRL 4,@VAR0 CALL HEXNS ST @TEMP2+1,@VAR0 SLL 4,@VAR0 SRL 4,@VAR0 CALL HEXNS CEQ COMMAZ,@CHAT BR ERRSYN CALL NGOOD BR HEXDON HEXNS CHE >0A,@VAR0 BR HEXNS2 ADD >07,@VAR0 HEXNS2 ADD >30,@VAR0 ST @VAR0,V*STRPTR DINC @STRPTR RTN HEXSTR DCLR @TEMP2 DST @FAC4,@STRPTR DCHE 5,@FAC6 BS HEXS4 CASE @FAC7 BR HEXS0 BR HEXS1 BR HEXS2 BR HEXS3 BR HEXS4 HEXS4 CALL HEXSN SLL 4,@VAR0 ADD @VAR0,@TEMP2 HEXS3 CALL HEXSN ADD @VAR0,@TEMP2 HEXS2 CALL HEXSN SLL 4,@VAR0 ADD @VAR0,@TEMP2+1 HEXS1 CALL HEXSN ADD @VAR0,@TEMP2+1 HEXS0 XML PGMCHR CALL SNDER CALL CLRFAC DST @TEMP2,@FAC CALL CIFSND HEXDON CEQ COMMAZ,@CHAT BS HEXAGN BR LNKRTN HEXSN ST V*STRPTR,@VAR0 CHE 103,@VAR0 * g ? BS ERRBA CHE 97,@VAR0 * a ? BR HEXSN2 SUB 32,@VAR0 * -32 HEXSN2 CHE 71,@VAR0 * G ? BS ERRBA CHE 65,@VAR0 * A ? BR HEXSN3 SUB 55,@VAR0 * -55 BR HEXSN4 HEXSN3 CHE 58,@VAR0 * : ? BS ERRBA CHE 48,@VAR0 * 0 ? BR ERRBA SUB 48,@VAR0 * -48 HEXSN4 DINC @STRPTR RTN ************************** RXBIO CALL SPNUM1 * IO IOAGN CALL GETNUM * TYPE 0-6 CHE >07,@FAC1 BS ERRBV ST @FAC1,@VARY CALL SUBLP3 * ADDRESS/ CASE @VARY * BITS/BYTES BR SOG BR SOV BR CRUI BR CRUO BR CSW BR CSR BR CSV SOG I/O 0,@FAC BR IODONE SOV I/O 1,@FAC BR IODONE CRUI CALL CRUSET I/O 2,@VAR4 XML PGMCHR CALL SNDER CALL CLRFAC ST @VAR0,@FAC1 CALL CIFSND * VARIABLE1 CHE >09,@VARY BS CRUI16 BR IODONE CRUI16 XML PGMCHR CALL SNDER CALL CLRFAC ST @VARV,@FAC1 CALL CIFSND * VARIABLE2 BR IODONE CRUO CALL CRUSET CALL SUBLP3 * VARIABLE1 DCHE >0100,@FAC BS ERRBV CHE >09,@VARY BS CRUO16 ST @FAC1,@VAR0 BR CRUO8 CRUO16 DST @FAC,@VAR0 CALL SUBLP3 * VARIABLE2 DCHE >0100,@FAC BS ERRBV ST @FAC1,@VARV CRUO8 I/O 3,@VAR4 BR IODONE CSW CALL CSLOAD I/O 4,@VAR4 BR IODONE CSR CALL CSLOAD I/O 5,@VAR4 BR IODONE CSV CALL CSLOAD I/O 6,@VAR4 IODONE CEQ >B3,@CHAT BS IOAGN BR LNKRTN CRUTMP DST @FAC,@VAR4 DCLR @VAR5 DCLR @VAR0 RTN CRUSET CZ @FAC1 BS ERRBV CHE >11,@FAC BS ERRBV ST @FAC1,@VARY CALL SUBLP3 * CRU-ADDRESS CALL CRUTMP ST @VARY,@VAR5 RTN CSLOAD CALL CRUTMP CALL SUBLP3 * ADDRESS DST @FAC,@VAR5 RTN ******************************* HVPNUM CLR @FAC11 Select XB FLP XML XCNS CEQ SPACE,*FAC11 Leading space? BR HVPUTN INC @FAC11 Supress space out DEC @FAC12 Shorten length HVPUTN CLR @BYTES ST @FAC12,@BYTES+1 Length XML GETSTR MOVE @BYTES,*FAC11,V*SREF Store in VDP rollout DST @SREF,@FAC4 VDP rollout address DST @BYTES,@FAC6 Store length RTN ******************************* HPUT CALL SPNUM1 * HPUT HPAGIN CALL ROWCOL Get ROW & COL CALL STRFCH Get string or number CEQ >65,@FAC2 String? BS HPUTS Yes CALL HVPNUM No, XCNS HPUTS DCZ @FAC6 BS HPOUT DCLR @FAC HPUTLP CALL PUTLP CALL HFMT DDEC @FAC6 BR HPUTLP HPOUT CEQ >B3,@CHAT BS HPAGIN BR XPTRTN ************************** VPUT CALL SPNUM1 * VPUT VPAGIN CALL ROWCOL Get ROW & COL CALL STRFCH Get string or number CEQ >65,@FAC2 String? BS VPUTS Yes CALL HVPNUM No, CNS VPUTS DCZ @FAC6 BS VPOUT DCLR @FAC VPUTLP CALL PUTLP CALL VFMT DDEC @FAC6 BS VPOUT CZ @YPT BR VPUTLP INC @XPT B VPUTLP VPOUT CEQ >B3,@CHAT BS VPAGIN BR XPTRTN **************************** HVGETS CALL ROWCOL CALL GETNUM DCGT >00FF,@FAC BS ERRBV * BAD VALUE DST @FAC,@BYTES DST @FAC,@TEMP1 XML GETSTR DST @SREF,@STRPTR RTN **************************** HGET CALL SPNUM1 * HGET HAGAIN CALL HVGETS LP2 CALL GETLP CALL HFMT DDEC @TEMP1 BR LP2 HDONE CALL NGOOD CEQ >B3,@CHAT BS HAGAIN BR XPTRTN ************************** VGET CALL SPNUM1 * VGET VAGAIN CALL HVGETS LP1 CALL GETLP CALL VFMT DDEC @TEMP1 BS VDONE CZ @YPT BR LP1 INC @XPT B LP1 VDONE CALL NGOOD CEQ >B3,@CHAT BS VAGAIN BR XPTRTN *************************** GMOT CALL SPNUM1 * GMOTOIN GMAGN CALL SPNUM2 ST >02,@TEMP1 DST V@>0480(@SPSAL),@TEMP2 GMO1 CALL PREPN ST @TEMP2,@FAC+1 CH >7F,@FAC+1 BR GMO2 NEG @FAC+1 DNEG @FAC GMO2 CALL CIFSND CEQ >01,@TEMP1 BS GMO3 XML SPEED DATA >00B3 GMO3 EX @TEMP2,@TEMP2+1 DEC @TEMP1 BR GMO1 CEQ >B3,@CHAT BS GMAGN BR LNKRTN ************************** RMOT CALL SPNUM1 * RMOTION RMAGN XML PGMCHR CEQ >EC,@CHAT BR NOALL XML SPEED DATA >00EC DST >001C,@VAR0 NXALL DST @VAR0,@FAC CALL SPNUM5 BR RMALL NOALL DST >0001,@VAR0 CEQ >FD,@CHAT BR ERRSYN CALL NUMFCH CALL SPNUM4 RMALL DST V@>0480(@SPSAL),@TEMP1 ST >02,@TEMP2 RMOTLP CZ @TEMP1 BS J2 CEQ >80,@TEMP1 BS J3 CH >7F,@TEMP1 BS J1 NEG @TEMP1 BR J2 J1 ABS @TEMP1 J2 EX @TEMP1,@TEMP1+1 DEC @TEMP2 BR RMOTLP DST @TEMP1,V@>0480(@SPSAL) J3 DDEC @VAR0 BR NXALL CEQ >B3,@CHAT BS RMAGN BR LNKRTN ***************************************** S1ET9F XML SPEED * CHECK FROM DATA >021E * 30 TO 159 DATA >009F * RTN * ***************************************** INV CALL SPNUM1 * INVERSE(CHAR#) INVAGN XML PGMCHR CEQ >EC,@CHAT BR INOALL XML SPEED DATA >00EC DST >001E,@FAC DSLL 3,@FAC DST >01C8,@TEMP1 BR INVLP INOALL XML PARSE BYTE >B6 CALL S1ET9F DSLL 3,@FAC DST >0004,@TEMP1 INVLP DINV V@>0300(@FAC) DADD >0002,@FAC DDEC @TEMP1 BR INVLP INVNOK CEQ >B3,@CHAT BS INVAGN BR LNKRTN ***************************************** SSDSLL CALL STRFCH CALL S1ET9F DSLL 3,@FAC RTN ***************************************** SWCHR CALL SPNUM1 * SWAPCHAR(CHAR#,CHAR#) SWCHAG CALL SSDSLL DST @FAC,@VAR4 CEQ >B3,@CHAT BR ERRSYN CALL SSDSLL DST @FAC,@VAR5 MOVE 8,V@>0300(@VAR4),@FAC MOVE 8,V@>0300(@VAR5),V@>0300(@VAR4) MOVE 8,@FAC,V@>0300(@VAR5) CEQ >B3,@CHAT BS SWCHAG BR LNKRTN ****************************************** DUPCHR CALL SPNUM1 * DUPCHAR(CHAR#,CHAR#) DCHAGN CALL SSDSLL DST @FAC,@VAR4 CEQ >B3,@CHAT BR ERRSYN CALL SSDSLL MOVE 8,V@>0300(@VAR4),V@>0300(@FAC) CEQ >B3,@CHAT BS DCHAGN BR LNKRTN ****************************************** S00T10 XML SPEED * CHECK FROM DATA >0200 * 0 TO 16 DATA >0010 * RTN * ****************************************** SWCLR XML SPEED * SWAPCOLOR(SET#,SET#) DATA >00B7 SCOL10 CEQ >FD,@CHAT BR SCOL20 CALL SPNUM3 ST V@>0003(@FAC),@VAR4 DST @FAC,@VAR5 CEQ >FD,@CHAT BR ERRSYN CALL STRFCH CALL SPNUM4 ST V@>0003(@FAC),V@>0003(@VAR5) ST @VAR4,V@>0003(@FAC) CEQ >B3,@CHAT BR LNKRTN XML PGMCHR BR SCOL10 SCOL20 XML SPEED BYTE >01 CALL S00T10 DADD >080F,@FAC DST @FAC,@VAR4 XML PARSE BYTE >B6 CALL S00T10 DADD >080F,@FAC ST V*FAC,@VAR0 ST V*VAR4,V*FAC ST @VAR0,V*VAR4 CEQ >B3,@CHAT BR LNKRTN XML PGMCHR BR SCOL20 ****************************************** DUPCLR XML SPEED * DUPCOLOR(SET#,SET#) DATA >00B7 DCOL10 CEQ >FD,@CHAT BR DCOL20 CALL SPNUM3 ST V@>0003(@FAC),@VAR4 CEQ >FD,@CHAT BR ERRSYN CALL STRFCH CALL SPNUM4 ST @VAR4,V@>0003(@FAC) CEQ >B3,@CHAT BR LNKRTN XML PGMCHR BR DCOL10 DCOL20 XML SPEED BYTE >01 CALL S00T10 DADD >080F,@FAC ST V*FAC,@VAR0 XML PARSE BYTE >B6 CALL S00T10 DADD >080F,@FAC ST @VAR0,V*FAC CEQ >B3,@CHAT BR LNKRTN XML PGMCHR BR DCOL20 ******************************************************* * CPU PROGRAM FOR >8300 SCATCH PAD SUBROUTINE EXECUTE * ******************************************************* * AORG >8300 CPUPGM DATA >8302 * CPUPGM DATA >8302 First address. * DATA >0420 * BLWP >834A Switch contex * DATA >834A * FAC not used * DATA >04E0 * CLR @>837C Clear for GPL * DATA >837C * * DATA >045B * RT Return to GPL. * * END * ******************************************************* EXECUT CALL SPNUM1 EXAGN CALL SUBLP3 MOVE 12,@VAR0,V@VROAZ Save CPU values MOVE 12,G@CPUPGM,@VAR0 Load PGM DST @FAC,@VARY Load address XML >F0 Execute address MOVE 12,V@VROAZ,@VAR0 Restore CPU values CEQ >B3,@CHAT Comma? BS EXAGN Repeat BR LNKRTN *********************************************************** LINKST DATA LINKSU STRI 'SIZE' SIZE DATA $+2 B SZSIZE LINKSU DATA LINKSV STRI 'CLSALL' CLSALL DATA $+2 CALL CLSALL Close all open files BR LNKRT2 LINKSV DATA LINKSW STRI 'BYE' BYE DATA $+2 CALL CLSALL Close all open files EXIT LINKSW DATA LINKSX STRI 'NEW' NEW DATA $+2 RXBNEW CLR V@LODFLG Clear AUTOLOAD flag CALL CLSALL B SZNEW LINKSX DATA LINKSY STRI 'BIAS' BIAS DATA $+2 CALL SPNUM1 ( BIASAG CALL GETNUM Get number DST @FAC,@VAR0 Save number CALL STRGET Get string DST @FAC4,@VARY Save location DST @FAC6,@VARY2 Save length BIASLP ST V*VARY,@FAC1 * Character. DCZ @VAR0 0? BS BIASM Yes. ADD 96,@FAC1 ADD OFFSET BR BIASSV BIASM SUB 96,@FAC1 MINUS OFFSET BIASSV ST @FAC1,V*VARY Store it DINC @VARY Next one in string DDEC @VARY2 Counter-1 BR BIASLP Loop till zero CEQ >B3,@CHAT ,? BS BIASAG Yes BR LNKRTN Done return LINKSY DATA LINKSZ STRI 'EALR' EALR DATA $+2 CALL EASAVE BYTE >33 LINKSZ DATA LINKT1 STRI 'EAPGM' EAPGM DATA $+2 CALL EASAVE Get path BYTE >35 LINKT1 DATA LINKT2 STRI 'EAED' EAED DATA $+2 XEAED CALL EASAVE Get path BYTE >31 LINKT2 DATA LINKT3 STRI 'EA' EA menu DATA EAMENU EASAVE CALL SPNUM1 ( CALL STRGET Get path ST @FAC,V@>2256 Save length ADD 1,V@>2256 Length+1 MOVE @FAC6,V@0(@FAC4),V@>2257 Load buffer ST >0D,V@>2257(@FAC6) Put ENTER key at end FETCH @CHAT Get character EAMENU CALL CLSALL Close all open files B GE025 Got to EA CART LINKT3 DATA LINKT4 STRI 'XB' XB menu DATA $+2 XBMENU ST >FF,V@>35D7 SET RXB MENU Flag CALL CLSALL Close all open files BR RXBRUN Run it LINKT4 DATA LINKT5 STRI 'RUN' RUN(pathname) duplicat XBPGM DATA XBPGM LINKT5 DATA LINKT6 STRI 'XBPGM' XBPGM DATA $+2 XBPGM CALL SPNUM1 CALL CLSALL Close all open files CALL STRGET Get string DCZ @FAC6 Zero string length? BS RXBXBP Yes CLR V@>2254 Clear buffer MOVE 50,V@>2254,V@>2255 Ripple clear DST >994A,V@>2254 Set flag ST @FAC7,V@>2256 Save length byte MOVE @FAC6,V@0(@FAC4),V@>2257 Save string CLR V@>35D7 Clear RXB MENU Flag RXBXBP CEQ >B3,@CHAT Comma? BR RXBRUN No CALL RXBFIL Set files RXBRUN B TOPLEV RUN IT LINKT6 DATA >C010 STRI 'FILES' FILES DATA $+2 CALL SPNUM1 ( CALL CLSALL Close all open files CALL RXBFIL Set files BR RXBNEW Go do a NEW RXBFIL CALL SUBLP3 Get Files value DCZ @FAC Zero? BS ERRBV Yes, BAD VALUE error DCHE 16,@FAC 16 or more to high BS ERRBV Yes, BAD VALUE error CEQ RPARZ,@CHAT )? BR ERRSYN SYNTAX ERROR XML PGMCHR Skip ) DCLR @FAC2 Clear ST @FAC1,@FAC2 Load file value DST >0116,V@VROAZ Set files buffer space CALL DSKDSR RTN *********************************************************** * CALL KEY(string,keyunit,Nvarible,Nvariable...) * CALL KEY(keyunit,Nvariable,Nvarible...) *********************************************************** ZKEY CALL KEY Get key CEQ COMMAZ,@CHAT BS ZKEY BR LNKRTN *********************************************************** KEYJOY ST @FAC1,@VAR0 Keyboard selection CALL NUMVAR Get variable for key-code CEQ COMMAZ,@CHAT If not comma - error BR ERRSYN SYNTAX error XML PGMCHR Get next character CALL NUMVAR Get variable for key-status ST @VAR0,@KEYBD Keyboard selection MOVE 8,G@FLT1,@FAC Set up float CALL KEYSTR * RXB KEY STRING COMPARISON * ST @STATUS,@VARY Save stutus RTNC Return scan condition co *********************************************************** KEYSTR DCEQ >994A,@TOPSTK Flag set? BR RSCAN3 No. DST @VARY,@VARC String address. DST @CCPPTR,@ACCUM Copy length. CLR @BYTE3 Zero out counter RSCAN CEQ ONZ,@BYTE1 ON flag? BR RSCAN0 No SCAN Get a key B RSCAN1 Jump past normal KEY RSCAN0 SCAN Any key? BR RSCAN0 No. RSCAN1 DCZ @CCPPTR Length 0? BS RSCAN4 Yes. RSCAN2 INC @BYTE3 Counter +1 CEQ V*VARC,@RKEY Same? BS RSCAN5 Yes. DINC @VARC Address +1 DDEC @ACCUM Length -1 BR RSCAN2 No matcth. CEQ ONZ,@BYTE1 ON flag? BS RSCAN4 Yes B KEYSTR Restart. RSCAN3 SCAN Normal key scan. RSCAN4 CLR @KEYBD Clear key unit DCLR @TOPSTK Clear flag. RTNC Return save condition RSCAN5 CALL RSCAN4 CEQ @VAR0,@VAR0 Force condition bit on RTNC Return save condition *********************************************************** * CALL ONKEY(string,keyunit,variable,variable) * GOTO line#,line#,line#... *********************************************************** ZONKEY ST ONZ,@BYTE1 CZ @PRGFLG Program mode? BS ERRLNF ERROR LINE NOT FOUND CALL KEY Get normal key,status CZ @VARY Was a key pressed? BR GOTON0 No ONZ flag stays set CLR @BYTE1 Clear ONZ flag GOTON0 CEQ RPARZ,@CHAT ) BR ERRSYN SYNTAX ERROR XML PGMCHR Skip ) CEQ GOTOZ,@CHAT GOTO flag? BR ERRSYN SYNTAX ERROR CLR @BYTE2 Zero out Counter ONLP INC @BYTE2 Counter +1 XML PGMCHR Skip GO CEQ LNZ,@CHAT Line# token? BR ERRSYN SYNTAX ERROR XML PGMCHR Skip line# token ST @CHAT,@FAC Store high byte line# XML PGMCHR Skip high byte line# ST @CHAT,@FAC1 Store low byte line# XML PGMCHR Skip low byte line# CEQ @BYTE3,@BYTE2 $ counter = line# counter BR ONKEY1 No DST @FAC,@VARY Save line# ONKEY1 CEQ COMMAZ,@CHAT ,? BS ONLP Yes, keep going DST @VARY,@FAC Get saved line# CEQ ONZ,@BYTE1 ONZ flag? BS GKEY1 Yes, load line# CALL RETURN Return to XB ********************************************************** GKEY1 DST @ENLN,@FAC2 Get last address DSUB 3,@FAC2 Point to first LINE# GKEY2 CALL GRSUB3 Read from VDP/RAM BYTE FAC2 DCEQ @EEE1,@FAC Same? BS GKEY3 Yes, found line# DCH @STLN,@FAC2 No line# left BR ERRLNF ERROR LINE NOT FOUND DSUB 4,@FAC2 Next LINE# BR GKEY2 Loop GKEY3 DST @FAC2,@EXTRAM Got LINE# DADD 4,@EXTRAM Point to begining of line DINCT @EXTRAM Point to ADDRESS DST @EXTRAM,@PGMPTR Set pointer to line to run DINCT @PGMPTR Point to tokens CALL RETURN Return to XB ********************************************************** * SUBPROGRAM FOR 'JOYSTICK' ********************************************************** JOYST CALL SPAR KEY UNIT * RXB PATCH LABEL ************ JOYRPT XML SPEED Insure in range BYTE RANGE * of 1 - 4 BYTE 1 DATA 4 * GET VARIABLES FOR X, Y * AND SCAN KEYBOARD ST @FAC1,@VAR0 Keyboard selection CALL NUMVAR Get variable for key-code CEQ COMMAZ,@CHAT If not comma - error BR ERRSYN XML PGMCHR Get next character CALL NUMVAR Get variable for key-status ST @VAR0,@KEYBD Keyboard selection MOVE 8,G@FLT1,@FAC Set up float SCAN SCAN the keyboard CLR @KEYBD Clear the code(No affect on s ST @JOYY,@VAR0 JOYSTICK Y POSITION CALL JOYXY -4 to +4 DST >4001,@FAC Re-store F.P. 1 in FAC ST @JOYX,@VAR0 JOYSTICK X POSITION CALL JOYXY -4 to +4 RTN *********************************************************** ZJOYST CALL JOYST JOYAGN CEQ COMMAZ,@CHAT BR LNKRTN CALL CPAR2 CALL JOYRPT BR JOYAGN ************************************************************ SUBRTN RTN *************************** ERRFE CALL ERRZZ * BYTE 34 * DSKDSR DCHE 256,@VAR0 * BR DSRDSS * ADD >10,@VROAZ+1 * DSRDSS DST VROAZ,@FAC12 * CALL LINK * BYTE >0A * ST @ERCODE,@VAR2 * SRL 4,@FAC6 * CZ @FAC6 * BR ERRFE * CEQ >20,@VAR2 * BS ERRFE * RTN * *************************** * GCHAR PATCH FOR COMMA GCHARA CEQ COMMAZ,@CHAT ,? BS GCHAR BR XPTRTN *********************************************************** * MOTION PATCH for GO and STOP SPGS XML PGMCHR ( or , CEQ ALLZ,@CHAT ALL? BR SPGS1 No. XML PGMCHR Skip ALL XML PGMCHR Skip , DST 1,@FAC First sprite CALL SPNUM5 Get sprite table CALL SPMOVE Store velocity ST 28,@FAC Last sprite DCLR @VAR0 Index SPGSA MOVE 2,V@>0780,V@>0780(@VAR0) DADD 4,@VAR0 Index +4 DEC @FAC Sprite -1 BR SPGSA Done? B SPRMV4 No. SPGS1 CEQ NUMBEZ,@CHAT #? BR SPGS2 No. CALL SPNUM6 Standard routine. B SPRMV3 SPGS2 CEQ GOZ,@CHAT GO? BR SPGS3 No. AND >BF,@>83C2 GO!!! B SPGS4 Done. SPGS3 CEQ STOPZ,@CHAT STOP? BR ERRSYN No OR >40,@>83C2 STOP!!! SPGS4 XML PGMCHR Skip GO or STOP B SPRMV4 *********************************************************** SPAR CEQ LPARZ,@CHAT (? BS SPAR1 Yes. CEQ COMMAZ,@CHAT ,? BR ERRSYN No. SPAR1 XML PGMCHR Skip ( or , XML PARSE Get string or value. BYTE RPARZ CEQ >65,@FAC2 String? BR SPAR2 No. DST @FAC4,@VARY Save address. DST @FAC6,@VARY2 Save length. DST >994A,@TOPSTK Set flag. CALL LPAR RTN SPAR2 XML SPEED BYTE SYNCHK BYTE COMMAZ RTN ***************************** CPAR2 XML SPEED * Similar to LPAR DATA COMMAZ * Syntax check , BR GAC35 * Parse value ***************************** ZSCOI CALL SPRCOI * COINC COINLP CEQ >B3,@CHAT * BR LNKRTN * XML PGMCHR * CALL GAF56 * BR COINLP * ************************** NR CALL PREPN * AR XML ASSGNV * RTN * ************************** ZSDIST CALL DIST * DISTANCE DISLP CEQ >B3,@CHAT * BR LNKRTN * CALL GAFC4 * BR DISLP * ********************************************************* ...lee Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 8, 2020 Share Posted September 8, 2020 Very nice that you know where to find all this. So we are keeping "kosher" if we use similar methods. 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 8, 2020 Author Share Posted September 8, 2020 59 minutes ago, TheBF said: Very nice that you know where to find all this. So we are keeping "kosher" if we use similar methods. I think so. My corrigenda keep growing. I really must update my website ere long. ...lee 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 9, 2020 Share Posted September 9, 2020 Been busy today but finally tried my sprite collider with some different versions of COINC. So my new COINC is this. v@ reads 2 bytes. The code word SPLIT, splits the word into 2 bytes on the stack. This version measures 66 ticks of the 9901 clock include parameters : COINC ( spr#1 spr#2 tol -- ?) \ 1.4 mS, 1.1 mS optimized >R SP.Y V@ SPLIT ROT SP.Y V@ SPLIT ( -- col row col row) ROT - ABS R@ < -ROT - ABS R> < AND ; The original TI code has been named COINC.TI is being tested with my new SP.DIST which is about 2X faster than the original. My minor change is to change the DUP + to the code word 2*. This is called COINC.NEW My improved version times at 78 ticks The TI version is 83 ticks. The test: 1. Fire 2 sprites at each other at automotion speed 100 2. Read until COINC=TRUE 2. Report the distance between the sprites. (uses SQRT on the output of SP.DIST to a real value) Assumption: A faster COINC routine will halt with less overlap of the sprites ie: a greater distance. Here is the code. The word DETECTOR is a deferred word so we can change the action with the different versions of COINC The video shows the result. Spoiler \ coincidence test NEEDS RED FROM DSK1.COLORS NEEDS AUTOMOTION FROM DSK1.AUTOMOTION NEEDS DEFER FROM DSK1.DEFER DEFER DETECTOR ' COINC IS DETECTOR MARKER /REMOVE : SQRT ( n -- n ) -1 TUCK DO 2+ DUP +LOOP 2/ ; : COINC.NEW ( sp#1 sp#2 tol -- ? ) DUP * 2* -ROT SP.DIST >= ; : COINC.TI ( spr#1 spr#2 tol --- f ) ( 0= no coinc 1= coinc ) DUP * DUP + >R ( STACK: spr#1 spr#2 R: tol*tol+tol*tol) SP.DIST R> ( STACK: dist^2 2*tol^2) > 0= ; ( within tolerance? STACK: flag) STOPMOTION DECIMAL : COLLIDE ( speed -- ) PAGE ." Coincidence Collider" [CHAR] A DKRED 0 100 0 SPRITE [CHAR] B DKGRN 240 100 1 SPRITE 1 OVER NEGATE 1 MOTION 0 OVER 0 MOTION 0 22 AT-XY ." Speed= " . 0 23 AT-XY ." Press key to fire..." KEY DROP AUTOMOTION BEGIN 0 1 7 DETECTOR ?TERMINAL ABORT" halted" UNTIL STOPMOTION CR ." Distance= " 0 1 SP.DIST SQRT . ; SPRITECOLLIDER.mp4 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 9, 2020 Author Share Posted September 9, 2020 1 hour ago, TheBF said: Been busy today but finally tried my sprite collider with some different versions of COINC. Nice! I may try your collider tomorrow. Then, I need to pore over those three pages of fbForth 2.0:12 ALC to see how it compares, what with all the bank switching. On another note, did you notice that XB first checks the sprite coincidence status bit before even trying its COINC code, bailing if it is not set? That certainly makes its execution time a lot shorter with no hit (most of the time), but a bit longer with a hit—potentially (I think) missing the hit. What do you think? ...lee 1 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 9, 2020 Share Posted September 9, 2020 I missed that but it I have that commented out in mine. It's like : COINC COINCALL 0= IF EXIT THEN ...CONTINUED CODE HERE I will run that on the collider too. It should make the internal loop spin faster but sometimes the overhead of making decisions is slower than just doing the test. I will remove the BREAK code in the loop now that it is reliable as well. Numbers should change a little. Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 9, 2020 Author Share Posted September 9, 2020 11 hours ago, Lee Stewart said: Nice! I may try your collider tomorrow. Current ALC for COINC caught it at 2. Removing just that one, unnecessary JMP, I mentioned in the posted code, took it to 3! ...lee 2 Quote Link to comment Share on other sites More sharing options...
GDMike Posted September 9, 2020 Share Posted September 9, 2020 Surely theres room for error hit/miss. Maybe 50 percent, ok joking... but at least 1-2 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 11, 2020 Author Share Posted September 11, 2020 I have made a lot of changes to the graphics primitives relating to sprites, which now do less stack thrashing and have a bit more inline code for reading/writing VRAM than it had before. I still need to make a few more changes that are unnecessarily BL-ing and, then of course, there is that pesky thing called “testing”. Fortunately, all of this code refactoring has, so far, only cost me 14 bytes in Bank 1! ...lee 2 Quote Link to comment Share on other sites More sharing options...
+TheBF Posted September 11, 2020 Share Posted September 11, 2020 1 hour ago, Lee Stewart said: I have made a lot of changes to the graphics primitives relating to sprites, which now do less stack thrashing and have a bit more inline code for reading/writing VRAM than it had before. I still need to make a few more changes that are unnecessarily BL-ing and, then of course, there is that pesky thing called “testing”. Fortunately, all of this code refactoring has, so far, only cost me 14 bytes in Bank 1! ...lee I knew you deserved that wizard's hat. Felicitations 2 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 12, 2020 Author Share Posted September 12, 2020 As discussed above, I need to contrive a better method for deciding whether and how much SAMS memory is available to fbForth 2.0. If there is any, my method will conclude there is 32 MiB—wrong! One way, I suppose, would be to write to the highest page, shift the address right one bit and check if the written info is there, if it is, I did not have the bank I thought, so rinse and repeat until there is a change. I do not know if that method will produce the least code, but it’s a start. ...lee 1 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 13, 2020 Author Share Posted September 13, 2020 I believe I now have a good method for determining whether SAMS is present and how much if it is. It is ten bytes more than the previous code. The opening comments in the spoiler explain how the test is designed. Basically, the leftmost page bit of a test amount of SAMS is set and >000E added. If SAMS is present but not that high, page >000E will be redundantly mapped and the test will fail because that was the page that was written to in the first place. As the left bit is right-shifted to lower SAMS and if SAMS is present, the test will eventually succeed. At that point, the register with the roaming bit will have a value equal to half the number of pages. Doubling that number gets the right number of pages and decrementing it gets the top page#. The working assumption is that we do not need to worry about any SAMS below 128 KiB, so, if it fails at that amount, the "tracking" register will shift to>0008 and the loop will exit. Spoiler ;[*++ Check for presence of SAMS card. ***++ SAMS flag will be set to highest available page #. * To test, Map >000E + lowest bank not in next lower SAMS to >E000. * For 32 MiB, this is >1000 + >000E. We initially store >1000 in * R3 to allow shifting each round before MOVing to R0 to then * add >000E for the next test. If the test fails at >001E, the last * viable SAMS (128 KiB), R3 will go to >0008, at which point the loop * exits, setting R3 to 0, effectively reporting "no SAMS". * * Set up SAMS check. * LI R2,>994A check-value MOV R2,@>E000 check-value to check-location ; Classic99 emulator can do 32 MiB LI R3,>1000 lowest page above next lower SAMS to R3 LI R1,>401C load >E000 for SAMS register LI CRU,>1E00 CRU address of SAMS * * SAMS_CHECK: MOV R3,R0 lowest bank above next lower SAMS range AI R0,>000E get >000E pages higher SWPB R0 set up page# for SAMS register SBO 0 enable SAMS registers MOV R0,*R1 poke SAMS register SBZ 0 disable SAMS registers C @>E000,R2 compare possible copy with test value JNE SAMS_EXIT exit if SAMS mapped SRL R3,1 shift down by ^2 to next lower possibility CI R3,>0008 too far? JGT SAMS_CHECK try half as much if not >0008 CLR R3 no-SAMS..set flag to 0 JMP SAMS_EXIT0 we're outta here SAMS_EXIT: SLA R3,1 double value (highest page# + 1) DEC R3 decrement to highest page# SAMS_EXIT0: MOV R3,@ARG save SAMS flag to ARG (hoping it survives!) JEQ FRTHCP go to copying Forth inner interpreter if no SAMS * ...no need to restore anything if no SAMS * * Remap default bank >0E to >E000. * R1 and CRU should still have correct values. * LI R0,>0E00 load SAMS bank >000E SBO 0 enable SAMS registers MOV R0,*R1 poke SAMS register SBZ 0 disable SAMS registers ;]* I may fiddle with it to see whether I can reduce the code because that bank only has 134 bytes left. ...lee 3 Quote Link to comment Share on other sites More sharing options...
+Lee Stewart Posted September 13, 2020 Author Share Posted September 13, 2020 You may have noticed the time of my last post (2:17 AM). I had no intention of staying up that late last night, but at one point I added something to the code that caused the assembly to blow up. I panicked, thinking that somehow I had screwed up more than just the file I was editing because the surfeit of error messages made no sense. I finally figured out that the problem was a couple of odd characters I had included in a comment as is my wont—the open and close quotes (“ [alt+0147] and ” [alt+0148]). I am in such a habit of using them in any text I type that it did not occur to me to even look there. I did narrow it down to the comments, but was thinking that I might have hit some source-code size maximum. At one point, I thought the ‘#’ was the culprit. While poring over the added comments for anything else odd, those quotes sort of reached out and slapped me! Oh, well.... ...lee 1 Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.