# 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 +
  <CMOVE DROP ;         -->
# 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 <CMOVE ELSE 3 CMOVE THEN
  11 PAD C!
  PAD 9 + I - I SWAP BLANKS
  THEN  LOOP CR PAD DUP 1+ SWAP C@
 TYPE ."  being searched for " CR ; 
: ?LEGIT.BLOCK ( # -- #,t/f )
( false if 0 in block or too many ) 
  DUP OFFSET @ 2 / > 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 ! ;