# 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 ! ;