# 73 ( MOVE.SCREEN, MOVE.ALL ) FORTH DEFINITIONS DECIMAL : MOVE.SCREEN ( screen# -- ) 1 - 3 * DUP 3 + SWAP DO I 8 /MOD READ.SECTOR DROP I 25 + 8 /MOD WRITE.SECTOR LOOP ; : MOVE.ALL ( first-scr#, last# --) SWAP 1 - SWAP DO I MOVE.SCREEN -1 +LOOP ; ;S # 77 ( FORTH-79 DEFINITIONS ) FORTH DEFINITIONS DECIMAL : 1- 1 - ; : 2- 2 - ; : <> = 0= ; : DEPTH ( -- n ) SP@ S0 @ SWAP - 2 / ; : PICK ( n1 -- n2 ) ( If n1 >0, get the n1th. number ) ( from the stack, and return it on) ( top of the stack ) DEPTH 1- OVER < OVER 1 < OR ( check for bad index: leave true if bad, false if OK ) IF ." INDEX OUTSIDE LIMITS" 7 EMIT QUIT ELSE DUP + SP@ + @ THEN ; : ROLL ( n -- re-arranged stack ) >R R PICK SP@ DUP 2+ R> DUP + # 78 ( FORTH-79 DEFINITIONS ) FORTH DEFINITIONS DECIMAL : >< ( swap bytes ) ( FORTH DEF. ) DUP 256 / SWAP 255 AND 256 * + ; VOCABULARY FORTH-79 IMMEDIATE FORTH-79 DEFINITIONS DECIMAL : CREATE ( agrees with Brodie ) 0 VARIABLE -2 ALLOT ; : WORD ( -- address ) WORD HERE ; ;S # 79 ( CORDIC algorith ) ASM FORTH DEFINITIONS DECIMAL CODE RIGHT.SHIFT ( Y, X, #shifts -- Y,dY,X,dX ) EXX B POP D POP H POP H PUSH D PUSH 0 B MVI C A MOV 15 ANI A C MOV A ANA BEGIN 0= NOT WHILE H SRA L RR D SRA E RR C DCR REPEAT B POP D PUSH B PUSH H PUSH EXX NEXT JMP END-CODE 8192 VARIABLE ALFAS 4836 , 2555 , 1297 , 651 , 326 , 163 , 81 , 41 , 20 , 10 , 5 , 3 , 1 , 0 VARIABLE PICKS : ?NEG ( true if PICKS is 0 and ) ( top stack element is negative, ) ( or if PICKS is N and Nth element) ( is positive ) PICKS @ DUP 2+ DUP + SP@ + @ 0< SWAP IF 0= THEN ; --> # 80 ( CORDIC algorithm ) FORTH DEFINITIONS DECIMAL : CORDIC ( Y,X,ALPHA -- Y,X,ALPHA ) ROT 1002 1650 */ ROT 1002 1650 */ ROT ?NEG IF 16384 + ROT ROT MINUS SWAP ROT ELSE 16384 - ROT ROT SWAP MINUS ROT THEN 14 0 DO ?NEG IF I SWAP >R RIGHT.SHIFT + R> 2SWAP - ROT ROT I DUP + ALFAS + @ + ELSE I SWAP >R RIGHT.SHIFT - R> 2SWAP + ROT ROT I DUP + ALFAS + @ - THEN LOOP ; : ROTATION 0 PICKS ! CORDIC DROP ; : VECTORING 2 PICKS ! CORDIC ROT DROP ; --> # 81 ( CORDIC applications ) FORTH DEFINITIONS DECIMAL : POLAR->RECTANGULAR ( radius 16bitANGLE -- Y X ) 0 ROT ROT ROTATION ; HEX : PIRADIANS ( num denom -- 16bitANGLE ) MINUS 8000 ROT ROT */ ; DECIMAL : CENTIDEGREES ( angle*100 -- 16bitANGLE ) 18000 PIRADIANS ; : TOCENTIDEGREES ( 16bitANGLE -- angle*100 ) 18000 -32768 */ MINUS ; : SIN ( centidegrees -- SIN*10000 ) CENTIDEGREES 0 16384 ROT ROTATION DROP 10000 16384 */ ; : TAN CENTIDEGREES 0 16384 ROT ROTATION 10000 SWAP */ ; : COS CENTIDEGREES 0 16384 ROT ROTATION SWAP DROP 10000 16384 */ ; # 82 ( square root ) FORTH DEFINITIONS DECIMAL ASM CODE 2* ( n -- 2*n ) H POP L SLA H RL HPUSH JMP END-CODE CODE D2* ( d -- 2*d ) H POP D POP E SLA D RL L RL H RL DPUSH JMP END-CODE : D< ROT 2DUP = IF ROT ROT DMINUS D+ 0< ELSE SWAP < SWAP DROP THEN SWAP DROP ; : DU< 32768 + ROT 32768 + ROT ROT D< ; : EASY-BITS 0 DO >R D2* D2* R - DUP 0< IF R + R> 2* 1 - ELSE R> 2* 3 + THEN LOOP ; --> # 83 ( square root ) FORTH DEFINITIONS DECIMAL : 2'S-BIT >R D2* DUP 0< IF D2* R - R> 1+ ELSE D2* R 2DUP U< IF DROP R> 1 - ELSE - R> 1+ THEN THEN ; : 1'S-BIT >R DUP 0< IF 2DROP R> 1+ ELSE D2* 32768 R DU< 0= R> + THEN ; : SQRT ( ud -- u ) 0 1 8 EASY-BITS ROT DROP 6 EASY-BITS 2'S-BIT 1'S-BIT ; : XX ( n -- ;print sqrt to 3 dec. ) 16 * 62500 U* ( times 1 million ) SQRT 0 <# # # # 46 HOLD #S #> TYPE SPACE ; ;S # 84 ( conversion to Stockman's no'tion) FORTH DEFINITIONS DECIMAL : >STOCKMAN ( u -- u-2,u-1 ) ( convert an unsigned number to 2 ) ( unsigned numbers ) 0 ( creates unsigned double # ) 256 U/ ; : STOCKMAN> ( u-2,u-1 -- u ) ( converts Stockman's notation to ) ( unsigned single address ) 256 * + ; ;S # 85 ( MUSIC CASSETTE MANAGEMENT ) FORTH DEFINITIONS DECIMAL : .L (LINE) DROP 36 TYPE ; : LINES ( hi.limit, lo.limit -- ) DO CR 2 SPACES I SCR @ .L LOOP ; : CAS.LIST ( scr# -- ) ( make a cover for the cas. box ) DUP SCR ! 2 SPACES ." Cas # " . CR 16 3 LINES 3 0 LINES SCR @ 3 .R 21 16 LINES CR CR ; : CAS.INDEX ( scr# -- ) ( list cas# and title block ) DUP ." Cas # " . CR 3 0 DO I OVER .LINE CR LOOP DROP ; : CAS.REG ( scr# -- ) ( make a register entry for cas. ) DUP CAS.INDEX CR 21 3 DO 10 SPACES I OVER .LINE CR LOOP DROP ; --> # 86 ( MUSIC CASSETTE MANAGEMENT cont ) FORTH DEFINITIONS DECIMAL : CAS.LISTS ( first.scr,last.scr--) 1+ SWAP 0 #CR ! DO I CAS.LIST 40 #CR @ < IF 72 #CR @ DO CR LOOP 0 #CR ! THEN LOOP ; : CAS.INDEXS ( first.scr,last.scr--) 1+ SWAP 0 CR ! DO I CAS.INDEX 60 #CR @ < IF 72 #CR @ DO CR LOOP 0 #CR ! THEN LOOP ; : CAS.REGS ( first.scr,last.scr --) 1+ SWAP 0 #CR ! DO I CAS.REG 40 #CR @ < IF 72 #CR @ DO CR LOOP 0 #CR ! THEN LOOP ; ;S 1982.09.06 # 87 ( MATCH assembler 1 of 2 821026RMJ) FORTH DEFINITIONS ASM LABEL STRING.CHECK EXX B PUSH D PUSH H PUSH D DCX E A MOV D ORA 0= IF ( single char) H POP D POP B POP EXX STC RET THEN E C MOV D B MOV H POP H PUSH H INX EXX H PUSH EXX D POP BEGIN M A MOV XCHG M CMP 0= NOT IF ( no match ) H POP D POP B POP EXX STC CMC RET THEN H INX D INX B DCX C A MOV B ORA 0= UNTIL H POP D POP B POP EXX STC RET END-CODE ;S # 88 ( MATCH assembler 2 of 2 821026RMJ) FORTH DEFINITIONS ASM CODE MATCH D POP H POP EXX B POP H POP B D MOV C E MOV BEGIN EXX M A MOV EXX CPIR C A MOV B ORA 0= NOT WHILE STRING.CHECK CALL CS IF ( match found ) E A MOV C SUB A E MOV D A MOV B SBB A D MOV D PUSH EXX H POP D DAD H DCX 1 D LXI DPUSH JMP THEN REPEAT D PUSH EXX H POP 0 D LXI DPUSH JMP END-CODE ;S # 89 ( LOADING BLOCK FOR LIB ) ASM 63 LOAD 87 LOAD 88 LOAD 31 LOAD ( READ.SECTOR ) 90 LOAD 91 LOAD 92 LOAD 93 LOAD 94 LOAD 95 LOAD ;S # 90 ( LIB 1 of new version ) FORTH DEFINITIONS DECIMAL 16 CONSTANT NAM.LENGTH 255 CCONSTANT INVALID.NAM 0 VARIABLE CURRENT.NAM 0 VARIABLE DISK# : INITIALIZE ( # -- ) DUP 2 * DR1 OFFSET @ DR0 > IF CR ." No room for disc " . QUIT THEN 0 WARNING ! 0 CURRENT.NAM ! DUP DISK# ! DR0 2 * 1 - DR1 OFFSET @ DR0 + DUP BLOCK 768 BLANKS UPDATE 1+ BLOCK 768 BLANKS UPDATE DR0 0 DRIVE ! CR ; # 91 ( LIB 2 of new version ) FORTH DEFINITIONS DECIMAL : GET.SECTOR ( # -- ) 1 READ.SECTOR 16 1 DO 16 + DUP @ -1 = NOT IF DUP DUP >R @ DISK# @ 2 * 1 - CURRENT.NAM @ 59 /MOD ROT + DR1 BLOCK DR0 SWAP 13 * + DUP ROT SWAP ! 2 + SWAP 4 + SWAP 11 CMOVE 1 CURRENT.NAM +! R> THEN LOOP DROP ; : FIX.1.BLOCK ( addr -- t/f ) DR0 59 0 DO DUP 2+ C@ BL = IF DROP 0 ELSE DUP C@ OVER 1+ C@ 32 / SWAP READ.SECTOR 4 + 0 SWAP BEGIN DUP @ -1 XOR WHILE 1+ DUP 1+ SWAP C@ 31 AND ROT + 1+ SWAP REPEAT DROP OVER ! 13 + THEN DUP 0= IF LEAVE THEN LOOP ; # 92 ( LIB 3 of newlib ) FORTH DEFINITIONS DECIMAL : RECORD.FILE.SIZES ( -- ) DISK# @ 2 * 1 - DR1 BLOCK UPDATE FIX.1.BLOCK IF ( there is more ) DISK# @ 2 * DR1 BLOCK UPDATE FIX.1.BLOCK DROP THEN DR0 ; : PRINT.LIB.BLOCK ( n, addr -- n,tf) 59 0 DO DUP 2 + DUP C@ BL = IF 2DROP 0 LEAVE ELSE I 2 MOD 0= IF CR THEN 3 SPACES DUP 8 TYPE 46 EMIT 8 + 3 TYPE DUP @ DUP 4 .R ROT + SWAP 13 + THEN LOOP ; ;S # 93 ( LIB 4 of newlib ) FORTH DEFINITIONS DECIMAL : LIB ( # -- ) DUP CR ." Disc # " . CR DR1 2 * DUP 1 - BLOCK 0 SWAP PRINT.LIB.BLOCK IF ( there's more) SWAP BLOCK PRINT.LIB.BLOCK DROP ELSE SWAP DROP THEN DR0 CR ." No. sectors used = " DUP . CR ." No. sectors remaining " ." of 616 = " DUP 616 SWAP - . CR DUP 296 < IF 296 SWAP - ." No. " ." sectors remaining of 296 = " . ELSE DROP THEN CR ; : REG.DISK ( # -- ) INITIALIZE 8 0 DO I GET.SECTOR CURRENT.NAM @ 117 > IF LEAVE THEN LOOP RECORD.FILE.SIZES DISK# @ LIB 1 WARNING ! ; ;S # 94 ( LIB 5 of newlib ) FORTH DEFINITIONS DECIMAL : SEARCH.STRING ( -- ) ( enter search name into PAD ) HERE 14 BLANKS 127 WORD HERE PAD 14 CMOVE PAD 1+ DUP 10 + SWAP DO I C@ 46 = ( look for dot ) IF I 1+ PAD 9 + 2DUP < IF 3 IF 0 ELSE DUP 2 * 1 - BLOCK 2+ C@ THEN ; : INSPECT ( bl# -- t/f ) BLOCK 767 PAD DUP 1+ SWAP C@ MATCH DROP ; # 95 ( LIB 6 of newlib 821103RMJ) FORTH DEFINITIONS DECIMAL : SEARCH.BLOCK ( # -- #,t,f ) DUP 2 * 1 - INSPECT DUP 0= IF ( no match ) DROP DUP 2 * INSPECT THEN ; : LOCATE ( -- ) SEARCH.STRING 0 ( "previous" ) BEGIN DR1 1+ ?LEGIT.BLOCK WHILE SEARCH.BLOCK IF DUP LIB ." Continue search ?" Y/N 0= IF DROP QUIT THEN THEN REPEAT CR ." No more after " 1 - . CR DR0 ; : ERASE-DISK ( on drive 1 ) FLUSH EMPTY-BUFFERS DR1 OFFSET @ DUP 1+ SWAP OVER + SWAP DR0 DO I BUFFER DROP UPDATE I #BUFF MOD 0= IF FLUSH THEN LOOP FLUSH ; ;S # 96 ( HELKOPIA ) : HELKOPIA CR ." Copy from DR0 to DR1" CR BEGIN CR ." Are the discs in " ." place " Y/N UNTIL DENSITY @ CR ." Density set for " IF ." double" ELSE ." single" THEN CR ." Is that what you want" Y/N 0= IF DENSITY @ IF 0 ELSE 1 THEN DENSITY ! CR ." Density reset" CR THEN 26 0 DO DR0 I 8 /MOD READ.SECTOR DR1 I 8 /MOD WRITE.SECTOR LOOP DR1 OFFSET @ DR0 1 SWAP DR0->DR1 DR0 DENSITY @ 0= IF 7 39 READ.SECTOR DR1 7 39 WRITE.SECTOR THEN ; # 97 ( READ- WRITE- SECTOR 821022RMJ) FORTH DEFINITIONS DECIMAL 64786 @ CONSTANT DOSBUF : INIT-SEC ( sector, track -- adr ) OFFSET @ IF ( drive 1 expected ) 1 ELSE 0 THEN DRIVE ! SET-DRIVE TRACK ! SEC ! USE @ DOSBUF USE ! ; : READ.SECTOR ( sector,track --adr) INIT-SEC SEC-READ USE ! DOSBUF ; : WRITE.SECTOR ( sector, track -- ) INIT-SEC SEC-WRITE USE ! ;