( KERNEL - LOAD BLOCK -  338 IS LAST BLOCK        5-22-86)      
 CR ." BUILDING STARFLIGHT KERNEL.COM "                         
 CR ." (assumes THOUGHTT.COM current kernal) "                  
                                                                
7 WIDTH !                                                       
                                                                
' ?UNRAVEL 2- ' (DISKERROR?) 4 + ! \ Diskerror unravel          
' EXIT     2- ' (DISKERROR?) 6 + ! \                            
                                                                
                                                                
                                                                
                                                                
8000 trans-allot                                                
newt-dp                                                         
4 343 THRU                                                      
                                                                
<08Nov02 -- polyFORTH assembler code deleted here since it's
            probably copyrighted in source form.>                                                                
                                                                
                                                                
                                                                
                                                                
( MEMORY - ON OFF                                      3-20-85) 
                                                                
CODE ON ( addr -- \ store a 1 into address)                     
  U POP 1 # 0 MOV  0 U ) MOV NEXT                               
                                                                
CODE OFF ( addr -- \ store a 0 into address)                    
  U POP 0 0 XOR  0 U ) MOV NEXT                                 
                                                                
                                                                
( MEMORY - CAPSON KEY                                  3-20-85) 
                                                                
                                                                
HEX                                                             
CODE: CAPSON                                                    
\ Turn on caps - all other shift states off.                    
  DS PUSHS  40 # 0 MOV  0 DS LSG  17 # U MOV                    
  0 U ) MOV B  DS POPS  NEXT                                    
DECIMAL                                                         
: KEY CAPSON KEY ;                                              
                                                                
                                                                
                                                                
( MEMORY - Long memory accessing                       9-17-85) 
CREATE ZZZ     10 ALLOT   ( assembly scratch space)             
CODE <LCMOVE ( fseg from tseg to count -- \ interseg <cmove)    
  W U MOV    1 POP  0 ES SSG  2 DS SSG  W POP  ES POPS          
  I ZZZ MOV  I POP  DS POPS 1 1 OR 0= NOT IF                    
  STD  1 W ADD W DEC  1 I ADD I DEC  REP MOVS B CLD THEN        
  0 ES LSG  2 DS LSG  ZZZ I MOV  U W MOV NEXT                   
                                                                
                                                                
                                                                
                                                                
( MATH - START BLOCK                                   850424 ) 
CODE 2^N ( n -- 2^n \ calc 2^n power)                           
  1 POP  0 0 XOR  HEX F9 C, DECIMAL 1 INC                       
  1NZ IF 0 RCL V THEN 0 PUSH NEXT                               
: BIT ( n -- 2^<n-1> ) 1- 2^N ;                                 
                                                                
CODE 16/ ( u -- u'\ unsigned divide by 16)                      
  0 POP  4 # 1 MOV  0 SHR V  0 PUSH NEXT                        
CODE 16* ( u -- u'\ unsigned multiply by 16)                    
  0 POP  4 # 1 MOV  0 SHL V  0 PUSH NEXT                        
CODE D16* ( d -- d' \ unsigned multiply by 16)                  
  0 POP  2 POP                                                  
  4 # 1 MOV  BEGIN  2 SHL 0 RCL  LOOP 2 PUSH  0 PUSH NEXT       
: 3* 3 * ; \ REVISE                                             
CODE 3+                                                         
  0 POP 3 # 0 ADD 0 PUSH NEXT                                   
( MEMORY - Long memory accessing  @DS ADDR>SEG         8-23-85) 
                                                                
CODE 1.5@ ( addr -- d \ fetch 24bit number)                     
  U POP  U ) PUSH  0 0 XOR  2 3) 0 MOV B  0 PUSH NEXT           
CODE 1.5! ( d addr -- \ store 24bit number at addr)             
  U POP  0 POP  0 2 3) MOV B  U ) POP NEXT                      
CODE @DS  ( -- DS \ get current data segment) DS PUSHS NEXT     
ASSEMBLER                                                       
SUB: {LCXCHG} ( ES:SEG,0:offset1,U:offset2 -- \ long exchange)  
  1 PUSH ES SEG U ) 1 MOV B 0 U XCHG  ES SEG U ) 1 XCHG B       
  0 U XCHG  1 ES SEG U ) MOV B 1 POP RET                        
                                                                
                                                                
                                                                
                                                                
                                                                
( MEMORY - Long memory accessing                      12-05-85) 
                                                                
CODE L+-@ ( seg addr -- n \ long byte fetch w/ sign extension)  
  2 DS SSG  U POP  DS POPS 0 0 XOR  U ) 0 MOV B                 
  CBW 0 PUSH  2 DS LSG NEXT                                     
                                                                
                                                                
                                                                
( ARRAY - VARIABLES                                    8-15-85) 
                                                                
( array accessing parameter flags)                              
V= SPHEREWRAP ( spherical wrappingflag)                         
V= SIGNEXTEND ( fetch routine flag:)                            
   ( 0=byte, 1=sign extend)                                     
V: 'CELLADDR ( pfa of current cell addr)                        
   ( calc routine)                                              
V: '! ( pfa of current store routine)                           
V: '@ ( pfa of current fetch routine)                           
V= 'ARRAY ( pfa of current array)                               
                                                                
                                                                
                                                                
                                                                
                                                                
( ARRAY - ARRAYSEG #BYTES #COLZ #ROWZ                   2-1-85) 
                                                                
: ARRAYSEG ( -- seg \ @ array base )                            
  ( segment for current array)                                  
  'ARRAY @ 6 + @ ;                                              
                                                                
: #BYTES ( -- len \ length of current)                          
  ( array not including the row offset)                         
  ( appended to the end)                                        
  'ARRAY @ 4 + @ ;                                              
                                                                
: #COLZ ( -- #cols \ @ #cols in current)                        
  ( array)  'ARRAY @ @ ;                                        
                                                                
: #ROWZ ( -- #rows \ @ #rows in current)                        
  ( array)  'ARRAY @ 2+ @ ;                                     
( ARRAY - ACELLADDR                                     2-1-85) 
                                                                
: ACELLADDR                                                     
  ( x y -- addr or )                                            
            ( x y -- seg offset \ )                             
  ( generic calc cell address routine)                          
  'ARRAY @ 'CELLADDR @EXECUTE  ;                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( ARRAY - LCELLADDR ?BELOWARRAY ADJUSTCOL               2-1-85) 
                                                                
CODE: LCELLADDR ( x y pfa -- seg offset )                       
  ( \ long cell addr calc)                                      
  U POP    6 # U ADD    U ) 0 MOV                               
  2 # U SUB   U ) 1 MOV   1 U MOV                               
  1 POP  1 SHL  1 U ADD  DS PUSHS                               
  0 DS LSG   U ) 1 MOV   DS POPS                                
  2 POP  2 1 ADD  0 PUSH  1 PUSH NEXT                           
                                                                
                                                                
                                                                
                                                                
( ARRAY - A! A@                                         2-1-85) 
                                                                
: A! ( val addr -- or)                                          
     ( val seg offset -- \ generic )                            
  ( store byte value into array)                                
  '! @EXECUTE ;                                                 
                                                                
: A@ ( addr -- val or )                                         
     ( seg offset -- val \ generic )                            
     ( fetch from array)                                        
  '@ @EXECUTE ;                                                 
                                                                
                                                                
                                                                
                                                                
                                                                
( ARRAY - !OFFSETS <assembly version>                  1-3-86)  
                                                                
CODE !OFFSETS ( pfa -- \ compute and store row offsets after)   
  ( array)                                                      
  U POP  I PUSH W PUSH R PUSH ES PUSHS                          
  U ) I MOV                     ( #COLZ)                        
  2 3) 1 MOV                    ( #ROWZ)                        
  4 3) R MOV                    ( #BYTES)                       
  6 3) PUSH ES POPS             ( ARRAYSEG)                     
  1 W MOV  W SHL  R W ADD  STD                                  
  BEGIN                                                         
    I 0 MOV  1 MUL  STOS                                        
  LOOP                                                          
  0 0 XOR STOS CLD                                              
  ES POPS R POP  W POP  I POP NEXT                              
                                                                
( ARRAY - ARRAY                                         2-1-85) 
                                                                
: ARRAY ( Xcols Yrows seg -- \)                                 
  ( compiles an array : at run time...)                         
  ( x y <child> -- seg&offset of cell)                          
  ( Organized in row major order with)                          
  ( origin in upper left corner. Pre-)                          
  ( computes row offset addresses and)                          
  ( appends table to end of array.)                             
  ( Array header format: [#col][#rows])                         
  ( [#bytes][seg] )                                             
  CREATE HERE >R >R SWAP , , ( seg pfa)                         
   I' @ I' 2+ @ * , R> , R>  ( pfa --)                          
   DROP ( !OFFSETS )                                            
  DOES>  LCELLADDR ;                                            
                                                                
( ARRAY - SETLARRAY                                    8-15-85) 
                                                                
: SETLARRAY ( pfa -- \ set long array)                          
  ( as current and set access vectors)                          
  'ARRAY !       ( make current array)                          
  ' LCELLADDR                                                   
  'CELLADDR !                                                   
  ' LC! '! !         ( storage method)                          
  SIGNEXTEND @                                                  
  IF ' L+-@                                                     
  ELSE ' LC@ THEN                                               
  '@ ! ;           ( retrieval method)                          
                                                                
                                                                
                                                                
                                                                
( ARRAY REGIONS - VARIABLES                             2-1-85) 
                                                                
( 1ST QUADRANT COORDINATE SYSTEM)                               
                                                                
V= XLL ( left  region boundary)                                 
V= YLL ( lower region boundary)                                 
V= XUR ( right region boundary)                                 
V= YUR ( upper region boundary)                                 
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( ARRAY REGIONS - FULLARRAY SETREGION                   2-1-85) 
                                                                
: FULLARRAY ( -- xll yll xur yur \ get)                         
  ( region boundaries for full current)                         
  ( array)                                                      
  0 0 #COLZ 1- #ROWZ 1- ;                                       
                                                                
: SETREGION ( xll yll xur yur -- \ set)                         
  ( region in array)                                            
  YUR ! XUR ! YLL ! XLL ! ;                                     
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( ARRAY REGIONS - FILLREGION                            2-1-85) 
                                                                
: FILLREGION ( c -- \ generic fill )                            
  ( current region of current array)                            
  YUR @ 1+ YLL @ DO ( for each row )                            
  XUR @ 1+ XLL @ DO ( for each col )                            
                 DUP I J ACELLADDR                              
                 A!                                             
                 LOOP LOOP DROP ;                               
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( DATA AREAS - CONSTANT - SINGLE LENGTH                 2-4-85) 
11     C= IHEADLEN     ( length of instance header)             
0      C: END-CX       ( end of context stack - patch later)    
0      C: END-V        ( end of vector  stack - patch later)    
62816  C: EM           ( end of available kernel mem)           
255    C= WHITE        ( lores color constant)                  
170    C= GREY1        ( lores color constant)                  
85     C= GREY2        ( lores color constant)                  
8      C= *MAPSCALE    ( multiplier to *map data)               
     2 C= SIGBLK      \ file signature data block               
0      C= ALOVSA      \ range of vsa's on starflit.a            
15999  C= AHIVSA                                                
16000  C= BLOVSA      \ range of vsa's on starflit.b            
38655  C= BHIVSA                                                
' NOP  C= 'ovBACK     \ close docking bay doors pfa             
0      c= musseg      \ music segment                           
( DATA AREAS - CONSTANT - SINGLE LENGTH                 2-4-85) 
136    C= BROWN        ( lores color constant)                  
68     C= RED          ( lores color constant)                  
204    C= ORANGE       ( lores color constant)                  
221    C= YELLOW       ( lores color constant)                  
187    C= LT-GREEN     ( lores color constant)                  
153    C= GREEN        ( lores color constant)                  
17     C= DK-GREEN     ( lores color constant)                  
51     C= LT-BLUE      ( lores color constant)                  
119    C= BLUE         ( lores color constant)                  
34     C= DK-BLUE      ( lores color constant)                  
 1     C= #HRS         ( game time limit in real time)          
0      C= ?FIRED-WEAPONS ( has player fired weapons? )          
0      C= ?A-SHIELDS-UP  ( are alien's shields up? )            
0      C= ?A-WEAPONS-ARMED ( are alien's weapons armed? )       
16384  C= DBUF-SIZE    \ byte size of display buffer            
( DATA AREAS - CONSTANT - SINGLE LENGTH               11/12/85) 
102    C= VIOLET       ( lores color constant)                  
238    C= PINK         ( lores color constant)                  
0      C= BLACK        ( lores color constant)                  
50     C= NULL-ICON    ( 0 radius circle icon)                  
253    C= SYS-ICON     ( star icon)                             
254    C= INVIS-ICON   ( invisible icon - may collide)          
255    C= FLUX-ICON    ( flux icon identifier)                  
2      C= DEAD-IC      ( indicates red 'x' over icon)           
1      C= DEFAULT-IC   ( no special color handling)             
38     C= TEXTC/L      ( text window char per line)             
720    C: ILIMIT       ( quantity limit of icons in list)       
5      C= FUEL/SECTOR  ( fuel used/100 per sector traveled)     
0      C= POLYSEG                                               
' DROP C= 'ANSYS     \ analyze pfa (drops flag during initial   
                     \   set-up of ship in Arth sys)            
( DATA AREAS - CONSTANT - DOUBLE LENGTH                4-29-86) 
0.    2C= 0.           ( space saving constant)                 
0.    2C= NULL         ( null instance address)                 
3072. 2C= VANEWSPACE   ( iadr of newspace pointer)              
VANEWSPACE 6. D+ 2C= IROOT  \ iadr of root of all instances     
0.    2C= INACTIVE     ( iadr of inactive instance container)   
0.    2C= FRAGMENT     ( iadr of scratch node)                  
0.    2C= *SECS        ( iadr of box holding sec boxes)         
0.    2C= *ASSIGN-CREW ( iadr of crew assignment)               
0.    2C= *SHIP        ( iadr of starship)                      
0.    2C= *ASYS        ( iaddr of Arth system )                 
0.    2C= *ARTH        ( iaddr of Arth )                        
0.    2C= *ELAN        ( iaddr of Elowan nursery world )        
0.    2C= *BRAIN       ( iaddr of Uhlek Brain World )           
0.    2C= *HEAVENC     ( iaddr of Heaven Encounter )            
0.    2C= *ARREST      ( iaddr of Police Encounter )            
( DATA AREAS - CONSTANT - TABLE                        4-21-86) 
0.    2C= *SPHEXI      ( iaddr of SPHEXI )                      
0.    2C= *SP          ( iaddr of SPHEXI region w/CRYSTAL ORB ) 
1      C= MPS          ( m processor speed in arbitrary units ) 
                       ( 1 is slowest = PC < n = AT           ) 
                                                                
CREATE CLIP-TABLE ( polygon clipper parameters)                 
 2056 , 1 C, 119 ,   ( top,compare code,flip,x-inter)           
  514 , 0 C, 71 ,    ( right,compare code,flip,x-inter)         
 1028 , 1 C,  0 ,    ( bottom,compare code,flip,x-inter)        
  257 , 0 C,  0 ,    ( left boundary,compare code,flip,x-inter) 
                                                                
: TABLE CREATE DOES> SWAP 2* + @ ;                              
                                                                
                                                                
                                                                
( DATA AREAS - CONSTANT - TABLE                        12-09-85)
HEX ( & = bl but processed unlike space in parsers AWK 5/14/86) 
V: 3X5CHAR -2ALLOT ( 1FONT - ASCII 32-90)                       
  0000 , ( spc)  4904 , ( !  )  B400 , ( "  )  FFFF , ( #  )    
  F45E , ( $  )  A54A , ( %  )  0000 , ( &  )  4800 , ( '  )    
  2922 , ( [  )  8928 , ( ]  )  1550 , ( *  )  0BA0 , ( +  )    
  0128 , ( ,  )  0380 , ( -  )  0004 , ( .  )  2548 , ( /  )    
  F6DE , ( 0  )  4924 , ( 1  )  E7CE , ( 2  )  E59E , ( 3  )    
  B792 , ( 4  )  F39E , ( 5  )  D3DE , ( 6  )  E524 , ( 7  )    
  F7DE , ( 8  )  F792 , ( 9  )  0820 , ( :  )  0828 , ( ;  )    
  2A22 , ( <  )  1C70 , ( =  )  88A8 , ( >  )  E584 , ( ?  )    
  FFCE , ( @  )  57DA , ( A  )  D75C , ( B  )  7246 , ( C  )    
  D6DC , ( D  )  F34E , ( E  )  F348 , ( F  )  7256 , ( G  )    
  B7DA , ( H  )  E92E , ( I  )  24DE , ( J  )  B75A , ( K  )    
  924E , ( L  )  BFDA , ( M  )  BFFA , ( N  )  56D4 , ( O  )    
  F7C8 , ( P  )  F7A6 , ( Q  )  F7EA , ( R  )  739C , ( S  )    
( DATA AREAS - CONSTANT - TABLE                         2-4-85) 
HEX                                                             
  E924 , ( T  )  B6DE , ( U  )  B6D4 , ( V  )  B7FA , ( W  )    
  B55A , ( X  )  B7A4 , ( Y  )  E54E , ( Z  )                   
V: 5X5CHAR -2ALLOT ( ASCII 91-94, arrow shapes)                 
  233E , C200 , ( [ left arrow)                                 
  213E , E200 , ( \ down arrow)                                 
  21BE , 6200 , ( ] right arrow)                                
  23BE , 4200 , ( ^ up arrow)                                   
DECIMAL                                                         
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( DATA AREAS - CONSTANT - TABLE                         2-4-85) 
HEX                                                             
V: 7CHAR -2ALLOT  ( 2FONT - ASCII 32-90)                        
  0000 , 0000 , 0000 , ( spc)  0000 , 0000 , 0000 , ( !  )      
  0000 , 0000 , 0000 , ( "  )  0000 , 0000 , 0000 , ( #  )      
  0000 , 0000 , 0000 , ( $  )  0000 , 0000 , 0000 , ( %  )      
  0000 , 0000 , 0000 , ( &  )  6F00 , 0000 , 0000 , ( '  )      
  0000 , 0000 , 0000 , ( [  )  0000 , 0000 , 0000 , ( ]  )      
  0000 , 0000 , 0000 , ( *  )  0000 , 0000 , 0000 , ( +  )      
  0006 , F000 , 0000 , ( ,  )  0070 , 0000 , 0000 , ( -  )      
  0200 , 0000 , 0000 , ( .  )  0000 , 0000 , 0000 , ( /  )      
  76F7 , BDED , C000 , ( 0  )  6718 , C633 , C000 , ( 1  )      
  76C6 , 6663 , E000 , ( 2  )  76C6 , 61ED , C000 , ( 3  )      
  35AD , 6F98 , C000 , ( 4  )  FE31 , E1ED , C000 , ( 5  )      
  76F1 , EDED , C000 , ( 6  )  FEC6 , 6631 , 8000 , ( 7  )      
  76F6 , EDED , C000 , ( 8  )  76F6 , F1ED , C000 , ( 9  )      
( DATA AREAS - CONSTANT - TABLE                         2-4-85) 
HEX                                                             
  1400 , 0000 , 0000 , ( :  )  0000 , 0000 , 0000 , ( ;  )      
  0000 , 0000 , 0000 , ( <  )  0000 , 0000 , 0000 , ( =  )      
  0000 , 0000 , 0000 , ( >  )  0000 , 0000 , 0000 , ( ?  )      
  0000 , 0000 , 0000 , ( @  )  3673 , 9FE7 , 2000 , ( A  )      
  EDDE , DDE7 , 0000 , ( B  )  34CC , C430 , 0000 , ( C  )      
  EDDD , DDE0 , 0000 , ( D  )  FCCE , CCF0 , 0000 , ( E  )      
  FCCE , CCC0 , 0000 , ( F  )  3231 , 8DA4 , C000 , ( G  )      
  CE73 , FCE7 , 2000 , ( H  )  F666 , 66F0 , 0000 , ( I  )      
  3333 , 3BF0 , 0000 , ( J  )  DDDD , EDD0 , 0000 , ( K  )      
  CCCC , CCF0 , 0000 , ( L  )  C71E , F5C7 , 1C40 , ( M  )      
  CE7B , BCE7 , 3900 , ( N  )  3273 , 9CE5 , C000 , ( O  )      
  FDDD , FCC0 , 0000 , ( P  )  312C , B2D9 , 2340 , ( Q  )      
  FDDD , EDD0 , 0000 , ( R  )  7CC6 , 33E0 , 0000 , ( S  )      
  F666 , 6660 , 0000 , ( T  )  CE73 , 9CE7 , E000 , ( U  )      
( DATA AREAS - CONSTANT - TABLE                         2-4-85) 
HEX  CE73 , 9CE4 , C000 , ( V  )  C71C , 71D7 , F280 , ( W  )   
     DDD2 , DDD0 , 0000 , ( X  )  DDDD , F660 , 0000 , ( Y  )   
     F324 , CCF0 , 0000 , ( Z  ) DECIMAL                        
V: 7SPACING -2ALLOT                                             
  4 C, ( spc)  4 C, ( !  )  4 C, ( "  )  4 C, ( #  )            
  4 C, ( $  )  4 C, ( %  )  5 C, ( &  )  3 C, ( '  )            
  4 C, ( [  )  4 C, ( ]  )  4 C, ( *  )  4 C, ( +  )            
  3 C, ( ,  )  3 C, ( -  )  1 C, ( .  )  4 C, ( /  )            
  5 C, ( 0  )  5 C, ( 1  )  5 C, ( 2  )  5 C, ( 3  )            
  5 C, ( 4  )  5 C, ( 5  )  5 C, ( 6  )  5 C, ( 7  )            
  5 C, ( 8  )  5 C, ( 9  )  1 C, ( :  )  1 C, ( ;  )            
  4 C, ( <  )  4 C, ( =  )  4 C, ( >  )  4 C, ( ?  )            
  4 C, ( @  )  5 C, ( A  )  4 C, ( B  )  4 C, ( C  )            
  4 C, ( D  )  4 C, ( E  )  4 C, ( F  )  5 C, ( G  )            
  5 C, ( H  )  4 C, ( I  )  4 C, ( J  )  4 C, ( K  )            
( DATA AREAS - CONSTANT - TABLE                         2-4-85) 
  4 C, ( L  )  6 C, ( M  )  5 C, ( N  )  5 C, ( O  )            
  4 C, ( P  )  6 C, ( Q  )  4 C, ( R  )  4 C, ( S  )            
  4 C, ( T  )  5 C, ( U  )  5 C, ( V  )  6 C, ( W  )            
  4 C, ( X  )  4 C, ( Y  )  4 C, ( Z  )                         
                                                                
                                                                
( DATA AREAS - CONSTANT - TABLE                         2-4-85) 
HEX                                                             
V: 9CHAR -2ALLOT ( 3FONT - ASCII 65-90)                         
  3673 , 9CFF , 39C8 , 0000 , ( A  )                            
  EDDD , EDDD , E000 , 0000 , ( B  )                            
  34CC , CCC4 , 3000 , 0000 , ( C  )                            
  EDDD , DDDD , E000 , 0000 , ( D  )                            
  FCCC , ECCC , F000 , 0000 , ( E  )                            
  FCCC , ECCC , C000 , 0000 , ( F  )                            
  3231 , 8C6F , 2930 , 0000 , ( G  )                            
  CE73 , 9FE7 , 39C8 , 0000 , ( H  )                            
  F666 , 6666 , F000 , 0000 , ( I  )                            
  3333 , 333B , F000 , 0000 , ( J  )                            
  DDDD , DEDD , D000 , 0000 , ( K  )                            
  CCCC , CCCC , F000 , 0000 , ( L  )                            
  C71E , F5C7 , 1C71 , C400 , ( M  )                            
( DATA AREAS - CONSTANT - TABLE                         2-4-85) 
HEX                                                             
  CE7B , BCE7 , 39C8 , 0000 , ( N  )                            
  3273 , 9CE7 , 2930 , 0000 , ( O  )                            
  FDDD , DFCC , C000 , 0000 , ( P  )                            
  312C , B2CB , 2D92 , 3400 , ( Q  )                            
  FDDD , DFED , D000 , 0000 , ( R  )                            
  7CCC , 6333 , E000 , 0000 , ( S  )                            
  F666 , 6666 , 6000 , 0000 , ( T  )                            
  CE73 , 9CE7 , 39F8 , 0000 , ( U  )                            
  CE73 , 9CE7 , 3930 , 0000 , ( V  )                            
  C71C , 71C7 , 1D7A , 2800 , ( W  )                            
  DDDD , 2DDD , D000 , 0000 , ( X  )                            
  DDDD , DF66 , 6000 , 0000 , ( Y  )                            
  F332 , 4CCC , F000 , 0000 , ( Z  ) DECIMAL                    
                                                                
( DATA AREAS - CONSTANT - TABLE                        2-20-85) 
HEX                                                             
V: CURVE -2ALLOT ( normally distrib. rand number table)         
  0800 , 8810 , 8988 , 5525 , 5755 , 7775 , 7F77 , FF7F ,       
  FEFF , EEF7 , AEEE , AAAE , A4A4 , 1191 , 0811 , 0010 ,       
                                                                
                                                                
V: 1LOGO -2ALLOT ( interstel logo)                              
 3F1F , EEDF , 330C , 030C , CFB7 , 7F8F , C000 ,               
V: BUTTON -2ALLOT                                               
 7EC3 , BDA5 , A5A5 , BDC3 , 7E00 ,                             
V: HIGHLIGHT-BUTTON -2ALLOT                                     
 7A18 , 6186 , 1780 ,                                           
V: BUTTON-ON -2ALLOT                                            
 FC00 ,                                                         
DECIMAL                                                         
( DATA AREAS - VARIABLE - SINGLE LENGTH                4-30-86) 
V= 'XCOMM            \ extended comm pkg. pfa                   
V= TCLR              \ (un)nest console text color              
V= 'HEAT             \ crystal planet heating routine pfa       
V= 'TRAK             \ TRAK'ing encounters module pfa           
V= TRAK-HR           \ star-hr when last trak occurred          
V= A-STRENGTH        \ alien ship strength                      
V= DIRBLK DIRBLK OFF \ block offset for directory.              
V= TIMESTAMP         \ timestamp variable                       
V= RELAXTIME         \ relax timestamp restriction if on        
2V= VERSION          \ starflight version number                
VERSION 2+ OFF       \ starflight ov vers resets at data build  
V= ICONFONT                                                     
V= LFRAME                                                       
                                                                
                                                                
( DATA AREAS - VARIABLE - SINGLE LENGTH                5/15/86) 
V= SEED              \ random number seed)                      
V= ELEM-AMT          \                                          
V= 'INJURE           \                                          
V= P-COLOR 1 ALLOT   \ instance addr for planet descriptions    
V= P-PHRASE 1 ALLOT  \ ------------------"------------------    
V= P-CARP 1 ALLOT    \ ------------------"------------------    
V= O-COLOR 1 ALLOT   \ ------------------"------------------    
V= HYDRO             \ species#: hydrosphere compound           
V= ATMO              \    "      atmosphere     "               
V= LCOLOR            \ location cursor color                    
V= 'FLARE            \ stellar flare routine                    
V= (FLARE) -1 (FLARE) ! \ flare date for current starsys        
V= ?TV               \ is TVEHICLE available from ship?         
V= OLDHR             \ prior hour, for storms                   
                                                                
( DATA AREAS - VARIABLE - SINGLE LENGTH                4-30-86) 
V: LFILE#    \ last file number                                 
V: LRECORD#  \ last record number                               
V: LBADD     \ last buffer address for record                   
V= FILE#     \ current common attribute file#                   
V= RECORD#   \ current ca record #                              
V: 1BUFADR   \ lower block buffer head address                  
V: 2BUFADR   \ upper block buffer head address                  
V= CXSP      \ context stack pointer                            
V: VSP       \ vector  stack pointer                            
V: RDSK      \ lo-vsa of remembered disk                        
V= EDL       \ alien's emotional disposition level              
V= A-POSTURE \ alien's posture                                  
V: MXCIRC    \ Max radius of circle icon in world coords        
*MAPSCALE 10 * MXCIRC !                                         
V: #CIRC     \ Temp var used in ORGLIST                         
( DATA AREAS - VARIABLE - SINGLE LENGTH                4-30-86) 
V= P-RACES      \ crewmembers' races bit field                  
V: LOISEG       \ base address of oa-lo-word-table              
V: HIISEG       \ base address of oa-hi-byte-table              
V: $LOCSEG      \ base address of string location table         
V: $SEG         \ base address of string space                  
V: 'SWAPDISK    \ pfa of swap disk request                      
V= 'THROW-AWAY  \ pfa of current instance purging routine       
V= 'MAP         \ holds pfa of current mapping function         
V= 'TRAVERS     \ holds pfa of traversal function               
V= '?EXIT       \ holds pfa of exit condition testing word      
V: '?CHOICE     \ holds pfa of choice function word             
V= '.FLUX-ICON  \ display flux icon                             
V= ???IT        \ display artifact value                        
V= ?TD          \ for ITEMS in trade depot vs. planet or space  
V= ?BOMB ?BOMB OFF \ Plan# if black egg is dropped and armed    
( DATA AREAS - VARIABLE - SINGLE LENGTH                4-30-86) 
V= ?LANDED ?LANDED OFF ( has planet been landed on? )           
V: MAXINST   ( max. # of instances in cache, must be divis/16)  
V: QTYINST   ( current number of instances in cache)            
V: $MAX      ( offset from $seg of end of string space)         
V: $FREE     ( offset from $seg of free vector)                 
V: $OLD      ( old location of current string rel to $seg)      
V: $NEW      ( new location of current string rel to $seg)      
V: [IOFF]    ( location of current inst rel to looaseg)         
V: LENINST   ( length of current instance including len & updt) 
V= -END      ( amt of endurium to decrement/hyperspace move )   
V= OV#       ( current overlay vsa)                             
( V= OVA  current overlay base mem address -- see thoughtt.blk) 
V= ^VES      ( icon index# of vessel currently being tasked )   
V= REPAIRTIME -1 REPAIRTIME !                                   
V= ?ELAN ?ELAN ON ( Elowan planet Elan still in game? )         
( DATA AREAS - VARIABLE - SINGLE LENGTH                4-30-86) 
V= HBUF-SEG   \ hidden display buffer 16k                       
V= DBUF-SEG   \ screen display buffer 16k                       
V= COLOR      \ main color code                                 
V= DCOLOR     \ dither color code                               
V: YTAB       \ table pointer used in polygon fills             
V= Y1         \ line draw working var                           
V= X1         \ line draw working var                           
V= Y2         \ line draw working var                           
V= X2         \ line draw working var                           
V= YTABL      \ current scan line address table                 
V= BUF-SEG    \ current graphics buffer seg                     
V= BUF-CNT    \ number of bytes in current buffer               
V= RETURN     \ sbr return addr holder                          
V= ?SPHEXI ?SPHEXI ON ( planet Sphexi still in game? )          
V= ?WIN ?WIN OFF \ has the player won the game?                 
( DATA AREAS - VARIABLE - SINGLE LENGTH                4-30-86) 
V= #IN               \ count of vertices to clip/havebeen clpd  
V: #OUT              \ count of vertices output                 
V= VIN               \ address of input/output vertex array     
V= VOUT              \ address of temp output vertex array      
V= OIN               \ address of input outcode array           
V= OOUT              \ address of output outcode array          
V: IVPTR             \ input vertex array pointer               
V: OVPTR             \ output vertex array pointer              
V: ICPTR             \ input outcode array pointer              
V: OCPTR             \ output outcode array pointer             
V: FLIP              \ y/x intersection flag                    
V: TACCPT            \ trivial acceptance accumulator           
V= TRJCT             \ trivial rejection accumulator            
V= ?OPEN  ?OPEN OFF  \ vertex list open/closed flag             
V= ?EVAL  ?EVAL OFF  \ have any evaluations been filed?         
( DATA AREAS - VARIABLE - SINGLE LENGTH                4-30-86) 
V: SX V: SY V: SO    \ working variables y,x,outcode            
V: PX V: PY V: PO    \ working variables y,x,outcode            
V: IX V: IY V: IO    \ working variables y,x,outcode            
V: COMPARE-CODE      \ boundary comparison outcode              
V: X-INTER           \ x intercept of boundary                  
V= ILEFT  V= IRIGHT  \                                          
V= IBELOW V= IABOVE  \ intercepts used in OUTCODE               
V= 'FLY V= 'UNNEST   \ forward vector for FLY & UNNEST          
V= ?NEW              \ have we entered a new creature region    
V= FORCED            \ true to force tasker to perform some     
                     \ ahead of {?newhour} schedule             
V= #VESS #VESS OFF   \ # "alive" alien vessels in encounter     
V= CTCOLOR           \ text color for P>CT in comm-ov et al     
                                                                
                                                                
( DATA AREAS - VARIABLE - SINGLE LENGTH                4-30-86) 
V: SCAN       ( contains address of scan line table)            
V: ELEMENT    ( destination slot; either 0 or 1)                
V: SCAN+      ( value of SCAN + ELEMENT)                        
V: YMIN       ( minimum y value for polygon)                    
V: YMAX       ( maximum y value for polygon)                    
V: #HORIZ     ( # of horizontal line segments)                  
V= MOVED      ( per Bob)                                        
V= PLANTS     ( per Bob)                                        
V= ANIMALS    ( per Bob)                                        
V: FILTER  128 FILTER ! ( per Bob)                              
V= PEAK    128 PEAK !   ( per Bob)                              
V= MEMSEG     ( memory seg pointer)                             
V= MEMOFF     ( memory byte offset pointer)                     
V= MONITOR    ( monitor type code)                              
V= LOCRADIUS  ( radius of local area)                           
( DATA AREAS - VARIABLE - SINGLE LENGTH                 2-4-85) 
( INPUT PARAMETERS: NOTE: not changed by BLT)                   
V= yBLT    ( screen destination y, upper left pixel of BLT)     
V= xBLT    ( screen destination x, upper left pixel of BLT)     
V= XORMODE ( 1= XOR BLT foreground color, 0=Replace foreground) 
V= lBLT    ( length of BLT in pixels)                           
V= wBLT    ( width of BLT in pixels)                            
V= aBLT    ( address of BLT image bytes)                        
V= BLTSEG  ( blt pattern segment)                               
( WORKING VARIABLES:)                                           
V: BLT>    ( BLT image address pointer used by BLT)             
V: LPX     ( last pixel flag - used by BLT)                     
V= TILE-PTR  ( pointer to color word offset in tile-base)       
V= ?FUEL-DIE ( was there too little fuel to land when landing?) 
V= ?G-AWARE  ( was gravity successfuly ANALYSIS'ed )            
V= GWF       ( gravity warning flag )                           
( DATA AREAS - VARIABLE - SINGLE LENGTH                7/31/85) 
V= DXVIS V= DYVIS  ( delta TV window )                          
V= XCON            ( LL corner of contour - abs)                
V= YCON            ( LL corner of contour - abs)                
V= DXCON           ( change in xcon)                            
V= DYCON           ( change in ycon)                            
V= XVIS            ( LL corner of visible contour)              
V= YVIS            ( LL corner of visible contour)              
V= XLLDEST         ( LL in graphics buffer)                     
V= YLLDEST         ( LL in graphics buffer)                     
V= GLOBALSEED      ( global terrain anchor)                     
V= '.CELL          ( vector - array cell plot)                  
V= '.BACKGROUND    ( vector - background drawfctn)              
V= 'ICON-PRM       ( vector - icon parameter expert)            
V= 'ICONBOX        ( vector - icon > box )                      
V= 'CC             ( clear combat pfa forward vector )          
( DATA AREAS - VARIABLE - SINGLE LENGTH                 2-4-85) 
V: IXSEG        ( base seg of x world coordinate icon array)    
V: IYSEG        ( base seg of y world coordinate icon array)    
V: IDSEG        ( base seg of icon identifier array)            
V: ICSEG        ( base seg of icon color code array)            
V: ILSEG        ( base seg of icon idr array: lo-word)          
V= IHSEG        ( base seg of icon idr array: hi-byte)          
V= IGLOBAL      ( quantity of icons currently in list)          
V= ILOCAL       ( quantity of icons in local region)            
V= IINDEX       ( icon index pointer to current icon)           
V= XWLL V= YWLL ( wld coords - world window origin)             
V= XWUR V= YWUR ( wld coords - world window upper right corner) 
( screen window is defined in IBELOW, IABOVE, ILEFT, IRIGHT)    
V= *GLOBAL      ( qty icons in starmap)                         
*GLOBAL OFF IGLOBAL ON                                          
V= (STOP-COMM)  ( halt communications before next phrase )      
( DATA AREAS - VARIABLE - SINGLE LENGTH                 2-4-85) 
V: CENTERADJUST  ( amount subtracted )                          
   ( from screen coordinates to center icon at various scales)  
V= CONTEXT-ID#   ( 0=planet surface, 1=orbit, 2=system)         
                 ( 3=hyperspace, 4=encounter, 5=starport)       
V: EX                ( center of ellipse)                       
V: EY                ( center of ellipse)                       
V: ERAD              ( y radius of ellipse)                     
V: XNUMER            ( numerator of aspect ratio )              
V: XDENOM            ( denominator of aspect ratio)             
V: <ARC>             ( arc subr vector)                         
V= %EFF V= STORM V= 'TVT   ( behaviour tasks )                  
V= 'STORM ' BEEP 'STORM !  ( storm forward ref xeq routine )    
V= E/M                     ( for %eff in move and behave )      
V= FORCEPTASK   \ flag to force parrallel task before time      
FORCEPTASK OFF                                                  
( DATA AREAS - VARIABLE - SINGLE LENGTH               10/22/85) 
V= #STORM                                                       
V: XLOCUS             ( icon search origin - world coords)      
V: YLOCUS             ( icon search origin - world coords)      
V: RLOCUS             ( icon search radius - world coords)      
V: BICON              ( base icon for range functions)          
V= PORTDATE           ( last date player was at starport )      
V= ?PORT ?PORT OFF    ( at starport flag )                      
V: TVIS V: RVIS V= BVIS V= LVIS ( visible wind.- world coords)  
V= LFSEG              ( last free seg)                          
V= LSYSEG             ( large starsystem blt seg)               
V= MSYSEG             ( med.  starsystem blt seg)               
V= SSYSEG             ( small starsystem blt seg)               
V= ?REPAIR            ( something marked for repair? )          
?REPAIR OFF         \ set ?REPAIR to enable repair multitasking 
V= ?HEAL  ?HEAL OFF   ( anyone needs healing? )                 
( DATA AREAS - VARIABLE - SINGLE LENGTH                1-10-86) 
V= MXNEB            \ maximum world coord radius of nebula      
V= THIS-BUTTON      ( current button index )                    
V= NCRS             ( new cursor index )                        
V= OCRS             ( old cursor index )                        
V= WTOP             ( scroll window coords )                    
V= WBOTTOM          (          "           )                    
V= WRIGHT  V= WLEFT (          "           )                    
V= WLINES           ( # lines in scroll window )                
V= WCHARS           ( # chars per scroll window line )          
V= SKIP2NEST        ( T= don't double unnest from orb enc)      
V= -AIN             ( T= no alphas go thru #IN$ see MISC.CMP)   
V= 'LAUNCH          ( TRY-LAUNCH pfa )                          
V= ?ON-PLAN ?ON-PLAN OFF ( on Planet or in Starport? )          
V= ?RECALL ?RECALL OFF ( Emergency Distress Call issued? )      
V= WMSG WMSG OFF    ( play the win evaluation message )         
( DATA AREAS - VARIABLE - SINGLE LENGTH                 2/28/86)
V= ?ROD        ( ship has rod device- set by CC in COMBAT-OV )  
V= CTX         ( console text window char # , 0-37)             
V= CTY         ( console text window line # , 0-6)              
V= FTRIG       ( xyscan status flag - trigger pressed?)         
V= FQUIT       ( xyscan status flag - quit key pressed?)        
V= LKEY        ( ascii value of last key pressed)               
V= 'BUTTON     ( pfa of function routine)                       
V= BTN-REC#    ( ship console button record number)             
V= CRSCOLOR    ( cursor color - see MAKECRS)                    
V: (SRDEPTH)   ( subroot depth)                                 
V= ?>OP ?>OP OFF ( report to operations before any other room ) 
V= 'YANK       ( retrieval code pfa )                           
V= ?12         ( DODECAHEDRON on board? )                       
V= '+VESS      ( add alien vessels to encounter pfa )           
V= ?NEB ?NEB OFF ( is ship in a nebula? )                       
( DATA AREAS - VARIABLE - SINGLE LENGTH                 7-26-85)
V= FORCEKEY         ( force execution of 'KEY-CASE )            
V= %VAL             ( 1-100 % value adjustment)                 
V= SCROLL-LEN       ( # of entries in the scroll list)          
V= [#CACHE]         ( # of cache buffers possible )             
V= ESC-EN           ( ESC key enable flag )                     
V= ESC-PFA          ( pfa of ESCape invoked routine )           
V= LINE-COUNT       \ MODIFIES HIS CODE!                        
V= PM-PTR                                                       
V: ?REUSE           ( object creation option flag)              
V= SKEY             ( special key value buffer )                
V= #AUX             ( last aux window -- see buttons.cmp )      
                                                                
                                                                
                                                                
                                                                
( DATA AREAS - VARIABLE - SINGLE LENGTH               10/10/85) 
V= XABS       ( TV location on planet or ship in space)         
V= YABS       ( TV location on planet or ship in space)         
V= HEADING    ( TV or ship heading)                             
V= 3DSEG      ( base seg for 3D coord array)                    
V= VIN'       ( pointer to translated point array)              
V= YSCREEN    ( y display origin translation - scrn coords)     
V= XSCREEN    ( x display origin translation - scrn coords)     
V= 'COMBAT    ( combat overlay pfa ) ' BEEP 'COMBAT !           
V= 'CEX+      ( all communications experts ) ' NOP 'CEX+ !      
V= 'CEX       ( comm experts <AUX> <EDL> )   ' NOP 'CEX  !      
V= 'WAX       ( combat expert pfa )          ' NOP 'WAX  !      
V= TERMINATED ( communications terminated flag )                
V= ?COMBAT ?COMBAT OFF  ( combat button flag )                  
V= ?ATTACK    ( alien weapon fired flag )                       
                                                                
( DATA AREAS - VARIABLE - SINGLE LENGTH                8-15-85) 
V: ?RECYCLED       ( object re-allocation flag)                 
V= STAR-HR  STAR-HR OFF ( 0-23 )                                
V= STARDATE        ( 0-64 k)                                    
V= TIME-PASSING    ( time passage switch)                       
V= #CLRMAP         ( number of current colormap)                
V= PLHI -1 PLHI !  ( last creature file)                        
V= 'PROCESS        ( pfa of item process)                       
V: CURSEG          ( cursor bltseg base)                        
V= 'SIMULATE       ( forward vector for creature behaviour )    
V= 'DEATH          ( vector for crewmember death )              
V= 'ENDING         ( game-end execution vector )                
\ V= SYSK            ( #k configured for system )               
255 SYSK !         ( default memory size)                       
V= [KEYINT] \ 0= standard buffer, 1= 1 key buffer               
[KEYINT] OFF                                                    
( DATA AREAS - VARIABLE - SINGLE LENGTH                 2-4-85) 
V= 'CLEANUP         ( vector: termination task)                 
V= 'KEY-CASE        ( vector: key press CASE)                   
V= '.VITAL-SIGNS    ( vector: vital signs display)              
V= '.DATE           ( vector: date display)                     
V= '.VEHICLE-STATUS ( vector: vehicle status display)           
V= 'VEHICLE-CYCLE   ( vector: time slice test)                  
V= 'CREW-CYCLE      ( vector: time slice test)                  
V= 'EXTERNAL-EVENTS ( vector: external events)                  
V= 'REPAIR          ( vector: vehicle repair over time)         
V= 'TREATMENT       ( vector: medical treatment over time)      
V= WEAPON-FIRED     ( flag TRUE when weapon fired )             
V= ^CRIT            ( index into icon list: tasker )            
V= ?FLAT            ( TRUE if TV has flat device )              
                                                                
                                                                
( DATA AREAS - VARIABLE - SINGLE LENGTH                7/07/86 )
V= ?SUP                 \ shields are up?                       
V= E-USE                \ energy use amount for travel          
V= 'ENERGY              \ shield energy use pfa                 
V= ?SECURE              \ security breech flag TRUE=ARREST DATE 
V= 'STP ' NOP 'STP !    \ execution vector for STP breech       
V= 'RSIDE ' NOP 'RSIDE ! \ execution vector for STP 2nd Chance  
V= DERROR               \ contains last critical error code     
                                                                
TABLE OVT \ OUTPUT.VECTOR.TABLE                                 
  ' EMIT @ ME + ,  ' CR @ ME + ,  ' TYPE @ ME + , COLOR ,       
  XBLT , YBLT , WBLT , LBLT , ABLT , BLTSEG , XORMODE ,         
                                                                
                                                                
                                                                
                                                                
( DATA AREAS - VARIABLE - SINGLE LENGTH                4-30-86) 
                                                                
( DATA AREAS - VARIABLE - DOUBLE LENGTH                7/15/86) 
2V= TIRED-TIME      ( time alien gets tired of waiting for ans) 
2V= LASTREPAIR                                                  
2V= TALKCOUNT ( nothing happening timer )                       
2V= VSTIME 0. VSTIME 2! ( time to do a vehicle cycle? )         
2V= 10*CARGO         ( 10 M* %CARGO )                           
2V= SENSE-ADDR ( instance address of last SENSORed item)        
   0. SENSE-ADDR 1.5!                                           
2V= EYEXY  2V= WEAPXY                                           
2V= 10*END           \ amt of endurium on board ship            
2V= TOWFINE          \ amount fined for distress call           
2V= ENC-TIME         \ TIME after which encounters are enabled  
2V= NAV-TIME         \ -------"------- navigator is re-oriented 
2V: INT24            \ contains DOS  critical error vector      
2V= STIME            \ security check delta-time                
                                                                
( DATA AREAS - VARIABLE - DOUBLE LENGTH                 2-4-85) 
2V: VALIMIT   ( disk va pointer)                                
2V: DSKVA     ( disk va pointer)                                
2V: IADDR     ( current instance virtual address)               
2V: 1STOFF    ( iadr of 1st offspring)                          
2V= KEYTIME   ( time at which current key pressed)              
2V= LKEYTIME  ( time at which last key pressed)                 
2V= (SCROLL-BOX)       2V= (ORIGINATOR)                         
2V= (SCROLL-CONT)      2V= (AWARD) \ award message              
2V= BOX-IADDR          2V= (BOMB)  \ current bomb               
2V= REAL-MS/STAR-HR ( ratio of real millisecs to star-hrs)      
2V= LAST-UPDATE     ( real time clock value at .DATE)           
2V= XWLD:XPIX   ( wld > scr scale conversion factors)           
2V= YWLD:YPIX   ( wld > scr scale conversion factors)           
2V= ANCHOR      ( local area anchor x,y)                        
2V= OK-TALK-TIME ( clock time after which alien may talk )      
( DATA AREAS - VARIABLE - DOUBLE LENGTH                6/03/86) 
2V= (STARPORT)  ( iaddr of starport)                            
2V= (SHIP)      ( iaddr of starship)                            
2V= TVEHICLE    ( iaddr of terrain vehicle)                     
2V= TV-HOLD     ( iaddr of terrain vehicle hold)                
2V= SUPER-BOX   ( iaddr of                )                     
2V= (SYSTEM)    ( iaddr of current starsystem)                  
2V= (ORBIT)     ( iaddr of current orbit)                       
2V= (PLANET)    ( iaddr of current planet)                      
2V= (SURFACE)   ( iaddr of current planet surface)              
2V= (ENCOUNTER) ( iaddr of current enc) NULL (ENCOUNTER) 2!     
2V= (SHIPBOX)   ( iaddr of box containing ship instance)        
\ 2V= (ENCNTBOX)  ( iaddr of current encounter container )      
2V= (AORIGINATOR) NULL (AORIGINATOR) 2! ( iaddr of alien orig ) 
2V= THIS-REGION ( iaddr of box holding creatures in this area)  
2V= (THIS-ITEM) \ iaddr of current trade depot item             
( DATA AREAS - VARIABLE - ARRAY - SHORT                9-27-85) 
V: KEYINTADDR   ( keyboard vector address)                      
V: CXS        118 ALLOT   ( context stack)                      
V: VSTK        62 ALLOT   ( vector stack)                       
CXS 111 + ' END-CX !      ( patch initial cxsp addr)            
VSTK 60 + ' END-V  !      ( patch initial vsp addr)             
V= IBFR       271 ALLOT   ( instance buffer with format:)       
  ( [len][update][ instance string ]                   )        
  (   2      1          270                            )        
  ( len = len of instance string in bytes              )        
  ( update = 0 if no change, 1 if changed              )        
V= YTABLE      398 ALLOT ( full screen y display addr table)    
V: VYTABLE     238 ALLOT ( main view screen addr table)         
V= LSCAN       398 ALLOT ( scan conversion array)               
LSCAN SCAN !                                                    
                                                                
( DATA AREAS - VARIABLE - ARRAY - SHORT                 2-4-85) 
                                                                
V: NEB-TABLE 62 ALLOT                                           
V: NEB2      62 ALLOT                                           
V: V1        62 ALLOT                                           
V: V2        62 ALLOT                                           
V= CMAP      62 ALLOT     ( color map array)                    
                                                                
                                                                
( DATA AREAS - VARIABLE - ARRAY - LONG                  2-4-85) 
(                  dummy                          )             
( #cols   #rows   base seg           name         )             
  48        24       0     ARRAY MERCATOR                       
   9         7       0     ARRAY CONANCHOR                      
  61       101       0     ARRAY CONTOUR                        
  18        64       0     ARRAY ICONIMAGE                      
   3       134       0     ARRAY VERTEX   ( planet vertices)    
   4        72       0     ARRAY FACET    ( planet facet poly)  
   3        72       0     ARRAY FACE  ( polygon list heads)    
   5       800       0     ARRAY PPOLY ( planet color polygons) 
                                                                
( 15982 bytes)                                                  
                                                                
                                                                
                                                                
( DATA AREAS - VARIABLE - ARRAY - LONG                 9-24-85) 
(                 dummy                         )               
( #cols #rows   base seg           name         )               
   3     117       0     ARRAY GVERTEX  ( grid vertices)        
   4      89       0     ARRAY GPOLY    ( grid polygons)        
   2      89       0     ARRAY GRIDCOLOR ( grid poly colors)    
   3     117       0     ARRAY G1VERT ( grid vertices,xslated)  
   9       9       0     ARRAY 9X9COARSE ( coarse contour map)  
   9       9       0     ARRAY 9X9FINE   ( final site region)   
   6     134       0     ARRAY XFORMVERT ( vertices, xsformed)  
                                                                
                                                                
( 3330 bytes)                                                   
                                                                
                                                                
\ SETDBUF                                                       
HEX                                                             
HEAD: SETDBUF T: B800 DBUF-SEG ! T;                             
DECIMAL                                                         
                                                                
\ DOS critical error handler.                                   
HEX                                                             
CODE: FAILINT24 ( -- )                                          
\ DOS critical error call. Aways passes back a "fail"           
\ response. See file *>DOS.                                     
  80 #B 0 HI AND  0 #B 0 HI CMP  0= NOT                         
  IF DS PUSHS R PUSH DS POPS                                    
     4 I) 0 MOV     \ get device header attribute               
     DS POPS  8000 # 0 AND  0 0 OR  0=                          
     IF 0D # W MOV THEN                                         
  THEN                                                          
  W 0 MOV  2E C, ( CS SEG) 0 DERROR MOV B \ save error code     
  3 #B 0 MOV        \ always pass back fail                     
  0CF C, \ IRET                                                 
DECIMAL                                                         
                                                                
\ SETINT24 RESTOREINT24                                         
HEX                                                             
HEAD: SETINT24                                                  
T:  24 (!OLD) INT24 2!                                          
    @DS ' FAILINT24 24 (!SET) T;                                
                                                                
HEAD: RESTOREINT24                                              
T: INT24 2@ 24 (!SET) T;                                        
DECIMAL                                                         
\ indexcksum                                                    
exit                                                            
code indexcksum ( pfa -- n )                                    
\ Perform a check sum for array indices.                        
  u pop  i push  ds pushs                                       
  2 2 xor                                                       
  2 3) 1 mov     \ index count                                  
  4 3) i mov     \ index array offset                           
  6 3) push  ds pops  \ array seg                               
  begin  lods  0 2 add  loop                                    
  ds pops  i pop                                                
  2 push                                                        
  next                                                          
                                                                
                                                                
                                                                
\ iarrays indcksum ?badindex                                    
table iarrays \ pfa's of indexed arrays ( 15 )                  
  ' vertex    , ' facet     , ' face    , ' ppoly     ,         
  ' iconimage , ' gvertex   , ' gpoly   , ' gridcolor ,         
  ' g1vert    , ' 9x9coarse , ' 9x9fine , ' xformvert ,         
  ' mercator  , ' conanchor , ' contour ,                       
exit                                                            
v: indcksum   \ cksum for all indexed array indices             
head: indexcksums                                               
\ All array cksum.                                              
t:  0                                                           
  15 0 do i iarrays indexcksum + loop t;                        
                                                                
: ?badindex ( -- ) \ *** install in hourly loop                 
 indexcksums  indcksum @ - abort" BAD INDEX" ;                  
                                                                
                                                                
( INSTALL - LFCLAIM AINSTALL BINSTALL                   2-4-85) 
                                                                
HEAD: LFCLAIM                                                   
T: ( #segs -- seg \ claim space at end of avail mem)            
  NEGATE LFSEG @ + DUP LFSEG ! T;                               
                                                                
HEAD: AINSTALL                                                  
T: ( array-pfa -- install indexed array in memory)              
  DUP 'ARRAY ! #BYTES #ROWZ 2* + 16/ 1+ LFCLAIM OVER 6 + !      
  !OFFSETS T;                                                   
                                                                
HEAD: BINSTALL                                                  
T: ( base-ptr-pfa #segs -- \ install un-indexed array)          
  LFCLAIM SWAP ! T;                                             
                                                                
                                                                
\ new indexed array allocation technique                        
                                                                
head: ainstalls ( -- )                                          
\ Install indexed arrays.                                       
t: 15 0 do i iarrays ainstall loop                              
   ' ppoly 6 + @ ' polyseg ! t;                                 
\  indexcksums indcksum !  t;                                   
                                                                
                                                                
\ INSTALL - BINSTALLS                                           
head: binstalls T: ( -- \ install un-indexed arrays)            
  ' musseg 50  curseg 13  ssyseg  11  MSYSEG 28                 
  lSYSEG    47 \ large starsystem blt                           
  IHSEG     45 \ display sys: hi-byte iadr                      
  ILSEG     90 \ display sys: lo-word iadr                      
  ICSEG     45 \ display sys: color codes                       
  IDSEG     45 \ display sys: icon id#                          
  IYSEG     90 \ display sys: y world coordinate                
  IXSEG     90 \ display sys: x world coordinate                
  HIISEG    31 \ instance cache: hi-byte iadr                   
  LOISEG    62 \ instance cache: lo-word iadr                   
  $LOCSEG   62 \ instance cache: string pointers                
  $SEG     310 \ instance cache: string space                   
  HBUF-SEG 270 \ mainview screen buffer                         
  16 0 do binstall loop T;                                      
( INSTALL - ICINIT  INIT-CRS ?#K                        2-5-85) 
: ICINIT                                                        
  ( -- \ initialize instance cache)                             
  496  MAXINST !     ( maximum # of instances in cache)         
  4960 $MAX    !     ( maximum size of string space)            
  $FREE OFF          ( init string space pointer)               
  QTYINST OFF        ( init qty of instances in icache)         
  NULL IADDR 2!      ( null current instance)                   
  LFILE# OFF         ( IMPURE )                                 
  IBFR 2+ OFF        ( clear update flag) ;                     
                                                                
HEAD: INIT-CRS                                                  
T: ( -- \ turn on all bits in cursor space-INSTALL)             
  PAD 200 255 FILL  @DS PAD CURSEG @ 0 200 LCMOVE T;            
\ HEAD: ?#K                                                     
\ T: 18 INTERRUPT AX @ T;                                       
( INSTALL - KEYBOARD DRIVER                        DM  7-17-84) 
( courtesy of Dave Maynard                                    ) 
\ V= [KEYINT] \ 0= standard buffer, 1= 1 key buffer             
\ V= KEYINTADDR \ jmp vector pointer                            
[KEYINT] OFF                                                    
\ CODE (CLI) CLI NEXT                                           
\ CODE (STI) STI NEXT                                           
\ : INSTALLVEC ( addr seg int# -- \ install interrupt vector)   
\  (CLI) 4 * 2 + >R 0 I L! 0 R> 2- L! (STI) ;                   
\ 1A C= KEY-BUFR-HEAD                                           
\ 1C C= KEY-BUFR-TAIL                                           
\ 40 C= KEY-BUFR-SEG                                            
\  9 C= KEYINT                                                  
                                                                
                                                                
                                                                
\ XKEYINT INSTALLXKEY                                           
HEX                                                             
CODE XKEYINT ( keyboard interrupt prefix - clr buffr)           
  0 PUSH DS PUSHS 40 # 0 MOV  0 DS LSG                          
  0 0 XOR E4 C, 60 C, 80 # 0 AND 0= IF \ make?                  
  1C 0 MOV  0 1A MOV  THEN                                      
  DS POPS 0 POP EA C, HERE KEYINTADDR ! 0 , 0 , DECIMAL         
                                                                
: INSTALLXKEY ( -- \ install single key buffer)                 
  [KEYINT] @ 0= IF 9 (!OLD) KEYINTADDR @ 2! [KEYINT] ON         
                   @DS ' XKEYINT 9 (!SET)                       
                THEN ;                                          
hex                                                             
HEAD: KILLBREAK                                                 
\ Disable break key. valid for version 2.52 only.               
T: 1B8 2@ 1B (!SET) T; decimal                                  
\ FARB RESTOREKEY 'SETUP+/'RESTORE+ patch FLIMP                 
head: farb t: setsysk installxkey SETINT24  KILLBREAK T;        
                                                                
' farb 'SETUP+ ! \ grab mem from dos and set key vector.        
                                                                
: RESTOREKEY ( -- \ restore multi key buffer)                   
  [KEYINT] @ IF KEYINTADDR @ 2@ 9 (!SET)  [KEYINT] OFF THEN ;   
                                                                
HEAD: FLIMP T: RESTOREKEY RESTOREINT24 T;                       
                                                                
' FLIMP  'RESTORE+ !                                            
                                                                
                                                                
                                                                
                                                                
                                                                
( INSTALL - CONFIGURE-SYSTEM                           9-25-85) 
HEX : CFIGARRAYS ( -- )                                         
  SYSK @                ( -- #K in system)                      
  40 *                  ( -- #seg in system)                    
  1- LFSEG !            ( -- \ mark last free seg)              
  AINSTALLS             ( -- \ install indexed arrays)          
  BINSTALLS  ;          ( -- \ install un-indexed arrays)       
                                                                
: CONFIGURE-SYSTEM ( customize to environment)                  
  SETMAXDRV SETDBUF CFIGARRAYS                                  
  LFSEG @ @DS 1000 + -  ( -- #cache-segs)                       
  0 42 U/MOD SWAP DROP DUP [#CACHE] ! ( -- #cache-blks)         
  #CACHE !  AUTO-CACHE  ( -- \ set up auto cache)               
  BUFFER-BEGIN @ SEG>ADDR DUP 1BUFADR ! 410 + 2BUFADR !         
   ( disk buffers)                                              
  ICINIT INIT-CRS ;  DECIMAL                                    
( EXTENSION - CASE                                   11-22-85 ) 
                                                                
CODE: SCANCASE ( val pfa-case -- pfa-exec )                     
  U POP   0 POP   U ) 1 MOV                                     
  2 # U ADD  U ) 2 MOV  2 # U ADD                               
  BEGIN  U ) 0 CMP  0= IF 2 # U ADD U ) 2 MOV                   
                          1 # 1 MOV THEN                        
     4 # U ADD                                                  
  LOOP  2 PUSH NEXT                                             
                                                                
: CASE CREATE  HERE NULL , , 0 ( at compilation builds header)  
                         ( points to addr of # of pairs )       
                         ( HERE set to addr of value-1)         
   DOES>                 ( at execution, addr of # of pairs)    
   SCANCASE EXECUTE ;                                           
                                                                
( EXTENSION - CASE support, NOP                       2-20-85 ) 
: IS , [COMPILE] ' , 1+ ;  ( here, pair# -- here, next-pair#)   
: OTHERS  [COMPILE] ' 3 PICK  2+ !                              
                      SWAP ! ;  ( here , #-of-pairs      )      
                                                                
( CASE name                                      )              
(   a   IS   function-A                          )              
(   b   IS   function-B                          )              
(   c   IS   function-C                          )              
(   OTHERS   errorfunction                       )              
( pfa--> {#}{others}{val}{exec}{val}{exec}...    )              
                                                                
: CASE: ( <name>, n -- \ indexed executor definer)              
  CREATE SMUDGE ] DOES> SWAP DUP + + @ CFAEXEC ;                
  ( ie. CASE: OUTPUT-CASE { n -- }               )              
  (     NOP GET-PHRASE DECOMPRESS WRITE-PHRASE ; )              
( EXTENSION - CASE  transient version                11/22/85 ) 
                                                                
( MATH - random number )                                        
                                                                
CODE FRND ( -- u \ fast random number generator)                
  SEED 0 MOV  31421 # 1 MOV  1 IMUL  6927 # 0 ADD               
  0 SEED MOV  0 PUSH NEXT                                       
: RRND ( l h -- n \ generate random # in range l to h)          
  OVER - FRND U* SWAP DROP + ;                                  
                                                                
\ CODE ?BIT ( n # -- t \ test bit # in n)                       
\  1 POP  0 POP  1 INC  0 SHR V  CS IF 1 # 0 MOV ELSE 0 0 XOR   
\  THEN 0 PUSH NEXT                                             
CODE +BIT ( n -- n'\ sum the bits in n)                         
  2 2 XOR  0 POP  16 # 1 MOV  BEGIN  0 SHR  CS  IF 2 INC THEN   
  LOOP 2 PUSH NEXT                                              
                                                                
                                                                
( MATH - normally distrib. rand number                 2-20-85) 
                                                                
HEX                                                             
CODE (SLIPPER) ( [0<peak<256 --- [sample or 0] )                
  0 POP  0 U MOV                                                
  PEAK 1 MOV  1 U SUB  80 # U ADD  0 #B U HI CMP 0=             
  IF U 2 MOV  81 C, E2 C, 07 , 3 #B 1 MOV  U SHR V              
     8A C, 8F C, CURVE , FILTER U MOV  2 1 XCHG                 
     U SHR V                                                    
  ELSE U U SUB                                                  
  THEN                                                          
  2 U AND 0= NOT IF 0 PUSH THEN U PUSH NEXT                     
DECIMAL                                                         
                                                                
                                                                
                                                                
( MATH - SQUARE ROOT see forth dimensions iv #1 p. 10)          
                                                                
CODE: D2*  0 POP 1 POP 1 SHL 0 RCL 1 PUSH 0 PUSH NEXT           
CODE: EASY-BITS  1 POP  0 POP  2 POP  U POP  BEGIN  U SHL  2 RCL
  U SHL  2 RCL  0 2 SUB  0< IF 0 2 ADD 0 SHL 0 DEC  ELSE  0 INC 
  0 SHL 0 INC THEN LOOP U PUSH 2 PUSH 0 PUSH NEXT               
                                                                
HEAD: 2'S-BIT                                                   
T: >R  D2*  DUP 0< IF D2* R@ - R> 1+                            
    ELSE  D2* R@ 2DUP U< IF DROP R> 1- ELSE - R> 1+             
    THEN THEN T;                                                
HEAD: 1'S-BIT                                                   
T: >R  DUP 0<  IF  2DROP R> 1+ ELSE D2* 32768 R@                
    DU< 0= R> + THEN T;                                         
: SQRT ( ud1 -- u2)   0 1   8 EASY-BITS  ROT DROP  6 EASY-BITS  
    2'S-BIT  1'S-BIT ;                                          
( MATH -         +-@                                   2-20-85) 
                                                                
CODE +-@ ( addr -- n \ get sign extended byte at address)       
  U POP  U ) 0 MOV B  CBW 0 PUSH NEXT                           
                                                                
                                                                
( MEMORY - Long memory accessing                       8-23-85) 
                                                                
\ CODE L1.5! ( d seg offset -- \ store )                        
\  ( long 24 bit number)                                        
\  U POP 1 POP 0 POP 2 POP  DS PUSHS                            
\  1 DS LSG  2 U ) MOV  0 2 3) MOV B  DS POPS NEXT              
                                                                
CODE L1.5@ ( seg offset -- d \ fetch )                          
 ( long 24 bit number)                                          
 U POP 1 POP 0 DS SSG                                           
 1 DS LSG  U ) PUSH  1 1 XOR                                    
 2 3) 1 MOV B 1 PUSH  0 DS LSG NEXT                             
                                                                
                                                                
                                                                
                                                                
\ .ohs support                                                  
EXIT                                                            
: .INSTREC ( seg off -- )                                       
\ Display instance record parms.                                
  >R >R                                                         
  I I'      L@    5  .R     \ len                               
  I I'  2 + LC@   5  .R     \ update flag                       
  I I'  3 + L1.5@ 9 D.R     \ sib                               
  I I'  6 + L1.5@ 9 D.R     \ prev                              
  I I'  9 + L1.5@ 9 D.R     \ offspring                         
  I I' 12 + LC@   5  .R     \ class                             
  I I' 13 + LC@   5  .R     \ species                           
  R> R> 2DROP ;                                                 
                                                                
: .IBFR  CR IADDR 1.5@ 9 D.R @DS IBFR .INSTREC ;                
                                                                
\ .ohs support                                                  
EXIT                                                            
: .ICACHE                                                       
  QTYINST @ ?DUP IF CR                                          
  ." OFFSET IADDR  LEN UPDT   SIB   PREV   OFF   CLASS  SPECIES"
  0 DO  I 2* >R  LOISEG @ I L@   HIISEG @ I 2/ LC@ CR           
        I 4 .R  9 D.R  $SEG @ $LOCSEG @ R> L@ .INSTREC          
     KEY DROP                                                   
    LOOP THEN ;                                                 
                                                                
: .OHS          CR                                              
  ." IBFR" .IBFR  .ICACHE ;                                     
                                                                
                                                                
                                                                
                                                                
\ CACHE DUMP WORDS                                              
EXIT                                                            
: .BUFSTUFF ( SEG -- )                                          
  >R  I 0 L@ 6 .R                                               
      I 2 LC@ 5 .R                                              
      I 3 LC@ 5 .R                                              
      R> 6 L@ OFFSET @ - 5 .R ;                                 
                                                                
: .CACHE                                                        
  CR ."  C#   SEG   UPDATE  MT   BLK "                          
  CR ." LPREV:" LPREV @ .BUFSTUFF                               
  CR ." PREV :" PREV  @ .BUFSTUFF                               
  CR ." USE  :" USE   @ .BUFSTUFF                               
  #CACHE @ 0 DO CR I 5 .R  I 'CACHE ! [SEGCACHE] L@             
                .BUFSTUFF KEY DROP LOOP ;                       
                                                                
\ Storage synonyms without update checking                      
TRANSIENT                                                       
: isPrim CREATE [COMPILE] ' HERE 2- ! ;                         
RESIDENT                                                        
                                                                
isprim <C!>    C!                                               
isprim <!>     !                                                
isprim <1.5!>  1.5!                                             
isprim <+!>    +!                                               
isprim <D!>    2!                                               
SYN <OFF>   OFF                                                 
SYN <ON>    ON                                                  
SYN <BLOCK> BLOCK                                               
                                                                
                                                                
                                                                
( MEMORY - ?UPDATE                                     3-28-86) 
CODE ?UPDATE ( addr -- addr \ if addr is in a block buffer)     
  ( or instance buffer set the update flag )                    
  1 POP  1 1 OR 0<                                              
  IF 1BUFADR U MOV  U 2 MOV  7 # 2 ADD  2 1 CMP 0>              
     IF 1025 # 2 ADD  1 2 CMP 0>                                
        IF -1 #B 2 3) MOV                                       
        ELSE 2BUFADR U MOV U 2 MOV 7 # 2 ADD 2 1 CMP 0>         
            IF 1025 # 2 ADD 1 2 CMP 0> IF -1 #B 2 3) MOV THEN   
            THEN                                                
        THEN                                                    
     THEN                                                       
  ELSE IBFR 3 + # 1 CMP 0< NOT ( in instance bufr?)             
     IF IBFR 273 + # 1 CMP 0<                                   
     IF IBFR 2+ # U MOV -1 #B U ) MOV THEN THEN                 
  THEN 1 PUSH NEXT                                              
( MEMORY - Storage operators defined for virtual sys   1-10-85) 
                                                                
: C!   ( c addr -- ) ?UPDATE C! ;                               
: !    ( n addr -- ) ?UPDATE !  ;                               
: +!   ( n addr -- ) ?UPDATE +! ;                               
: 1.5! ( d addr -- ) ?UPDATE 1.5! ;                             
: 2!   ( d addr -- ) ?UPDATE 2! ;                               
: D!   ( d addr -- ) 2! ;                                       
: ON   ( addr -- )   ?UPDATE ON ;                               
: OFF  ( addr -- )   ?UPDATE OFF ;                              
: 2OFF ( addr -- ) ?UPDATE 0 0 ROT 2! ;                         
: CMOVE ( from to cnt -- ) OVER ?UPDATE DROP CMOVE ;            
: FILL  ( addr u b -- ) 3 PICK ?UPDATE DROP FILL ;              
                                                                
                                                                
                                                                
\ IMPURE BLOCK LBLOCK LOAD                                      
\ MODIFY LATER TO USE REFRESH                                   
HEAD: IMPURE ( -- )                                             
\ Mark block buffers as having been used thru other             
\ than the ohs.                                                 
T: LFILE# <OFF> LRECORD# <OFF> T;                               
                                                                
: BLOCK ( n -- addr )                                           
\ Modified block to safeguard object i/o.                       
  IMPURE BLOCK ;                                                
                                                                
: LBLOCK IMPURE LBLOCK ;                                        
                                                                
: LOAD  IMPURE LOAD ;                                           
                                                                
                                                                
\ 10-28-85 OHS                                                  
                                                                
\ String comparison operators                                   
                                                                
: -TEXT ( a1 n a2 -- n' )                                       
\ Compare two unpacked strings over length n.                   
\ n' = 0 if match, n' >0 if a1 > a2, n' 0< if a2 < a1           
  0 ROT 0 DO DROP OVER I + C@ OVER I + C@ - DUP 0= NOT          
             IF LEAVE THEN LOOP SWAP DROP SWAP DROP ;           
                                                                
: $= ( $addr1 $addr2 -- f )                                     
\ Compare packed strings and leave true if they match.          
  2DUP C@ SWAP C@ =                                             
  IF COUNT ROT 1+ -TEXT NOT                                     
  ELSE 2DROP 0                                                  
  THEN ;                                                        
\ FILE SIGNATURE FIELDS                                         
: SIGFLD ( offset -- a )                                        
\ File signature record disk field definer.                     
  CREATE , DOES> @ SIGBLK BLOCK + ;                             
                                                                
1008 SIGFLD :SIGNATURE  \ signature (lo-hi vsa)                 
1012 SIGFLD :TIMESTAMP  \ timestamp                             
1014 SIGFLD :CKSUM      \ check sum                             
1016 SIGFLD :SAVE       \ block & offset of save flag           
1018 SIGFLD :VERSION    \ starflight version number             
                                                                
:VERSION @ VERSION !    \ get version # from directory          
                                                                
                                                                
                                                                
                                                                
\ THRU VA>BLK                                                   
: THRU  2DUP = IF DROP LOAD ELSE 1+ SWAP                        
  DO I dup . LOAD LOOP THEN ;                                   
                                                                
CODE VA>BLK ( va -- offset blk )                                
\ Compute the disk blk and offset given virtual address         
\ where va is the byte offset from the beginning of the         
\ disk {double-len}.                                            
  0 POP            \ hi                                         
  2 POP            \ lo                                         
  10 # 1 MOV       \ shift count                                
  BEGIN  0 SHR  2 RCR  U RCR LOOP                               
  6 # 1 MOV                                                     
  U SHR V  U PUSH  2 PUSH NEXT                                  
                                                                
                                                                
\ VA>BUF @LO-HI-VSA                                             
: VA>BUF ( va -- addr )                                         
\ Fetch disk block containing virtual addr and leave the        
\ address in the buffer.                                        
  VA>BLK BLOCK + ;                                              
                                                                
HEAD: @LO-HI-VSA ( -- lo hi ) \          ?                      
\ Read vsa range of loaded disk. 23040 46016 = b disk           
T: :SIGNATURE 2@ SWAP T;                                        
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( DOS FILES - VARIABLES                                4-22-86) 
                                                                
\ V= RELAXTIME     \ if set, relax timestamp file constraints   
V= 'VERSIONERR   \ pfa of version error routine                 
                                                                
                                                                
( DOS FILES - ?AFILE ?BFILE ?TIMEFILE ?VERSION         5-08-86) 
                                                                
HEAD: ?AFILE ( -- t \ is the A file loaded?)                    
T: OFFSET @ 1500 = T;  \ move to disys                          
                                                                
HEAD: ?TIMEFILE ( -- t \ does loaded file match timestamp?)     
T: :TIMESTAMP @ TIMESTAMP @ = RELAXTIME @ OR T;                 
                                                                
HEAD: ?VERSION ( -- t )                                         
\ Is current file the correct version number?                   
T: VERSION @ :VERSION @ = T;                                    
                                                                
HEAD: VERSIONERROR ( addr ct -- )                               
\ Handle incompatible file version error given filename $.      
T: 'VERSIONERR @EXECUTE T;                                      
                                                                
( DOS FILES - MOUNTFILE                                4-23-86) 
V: MNT           \ fcb dependent mount stuff vector             
                                                                
HEAD: MOUNTFILE ( addr ct -- )                                  
\ Given filename string, mount it and verify timestamp and      
\ version numbers.                                              
T: BEGIN                                                        
    2DUP >TIB MNT @EXECUTE      \ mount file                    
    ?TIMEFILE NOT               \ verify timestamp #            
    ?VERSION  NOT OR            \ verify version #              
   WHILE                                                        
    2DUP VERSIONERROR           \ request correct file          
   REPEAT 2DROP T;                                              
                                                                
                                                                
                                                                
( DOS FILES - MOUNTA MOUNTB                            5-08-86) 
                                                                
HEAD: A-MNT                                                     
T: SYSUTIL SETFCB DROP DR3 T;                                   
HEAD: B-MNT                                                     
T: SYSTEM SETFCB DROP DR2 T;                                    
                                                                
: MOUNTA ( -- )                                                 
\ Mount correct version of STARA.COM file.                      
  ' A-MNT MNT ! " STARA.COM" MOUNTFILE ;                        
                                                                
: MOUNTB ( -- )                                                 
\ Mount correct version of STARB.COM file.                      
  ' B-MNT MNT ! " STARB.COM" MOUNTFILE ;                        
                                                                
                                                                
( DOS FILES - SWAPFILE MOUNT-VSA                       4-22-86) 
                                                                
HEAD: SWAPFILE ( -- )                                           
\ Mount other Starflight file.                                  
T: ?AFILE IF MOUNTB ELSE MOUNTA THEN T;                         
                                                                
HEAD: UWITHIN ( n lo hi -- t )                                  
T: ROT >R I SWAP U< SWAP R> 1+ U< AND T;                        
                                                                
HEAD: MOUNT-VSA ( vsa -- )                                      
\ Verify and mount disk containing vsa.                         
T: @LO-HI-VSA 1+      ( vsa lo hi+1 -- )                        
   UWITHIN NOT                                                  
   IF SWAPFILE THEN T;                                          
                                                                
                                                                
( DOS FILES - <VERSIONERROR>                           4-22-86) 
                                                                
HEAD: <VERSIONERROR> ( addr ct -- )                             
\ Warn user if correct file not loaded.                         
T: CR ." Place disk with the correct"                           
   CR TYPE ."  file and press any"                              
   CR ." key when ready." KEY DROP T;                           
                                                                
' <VERSIONERROR> 'VERSIONERR !  \ patch vector                  
                                                                
                                                                
\ REMEMBER-DISK RECALL-DISK VSA>VA                              
                                                                
\ HEAD: REMEMBER-DISK ( -- )                                    
\ Save vsa of current disk.                                     
\ T: @LO-HI-VSA DROP RDSK <!> T;                                
                                                                
\ HEAD: RECALL-DISK ( -- )                                      
\ Get remembered disk.                                          
\ T: RDSK @ MOUNT-VSA T;                                        
                                                                
HEAD: VSA>VA ( vsa -- va )                                      
\ Convert vsa to virtual byte address.                          
T: @LO-HI-VSA DROP - 0 D16* T;                                  
                                                                
                                                                
                                                                
\ |MEMDSK                                                       
HEAD: |MEMDSK ( seg vsa #segs tf -- )                           
\ Move data to/from memory from/to disk, tf=1-->disk.           
T: >R                          ( -- tf)                         
  >R DUP MOUNT-VSA            ( seg vsa -- #segs tf)            
  VSA>VA 2DUP DSKVA <D!>      ( seg va -- #segs tf)             
  R> 16* 0 D+ VALIMIT <D!>    ( seg -- tf)                      
  MEMSEG <!>  MEMOFF <OFF>    ( -- tf)                          
  BEGIN                                                         
    MEMSEG @ MEMOFF @         ( fseg foff -- tf )               
    DSKVA 2@ VA>BLK           ( fseg foff off blk -- tf)        
    OVER 1024 SWAP -          ( fs fo off blk #byt -- tf)       
    0 VALIMIT 2@ DSKVA 2@ D-                                    
                                                                
                                                                
                                                                
    DMIN DROP                 ( fs fo off blk #bytes -- tf)     
    >R BLOCK + @DS SWAP       ( fs fo ts to -- #bytes tf)       
    I'                        \ to disk?                        
    IF   UPDATE                                                 
    ELSE 2SWAP                \ from disk                       
    THEN                                                        
    I LCMOVE                    ( -- n tf \ #bytes moved)       
    I MEMOFF <+!>   R> 0        ( d -- tf \ #bytes moved)       
    DSKVA 2@ D+ 2DUP DSKVA <D!> ( d -- tf \ new dest va)        
    VALIMIT 2@ D=               ( t -- tf \ at limit?)          
  UNTIL                                                         
  R> DROP T;                                                    
                                                                
                                                                
: MEM>DSK ( seg vsa #segs -- )                                  
                                                                
\ Move data from memory to disk.                                
  1 |MEMDSK ;                                                   
                                                                
: MEM<DSK ( seg vsa #segs -- )                                  
\ Move data to memory from disk.                                
  0 |MEMDSK ;                                                   
                                                                
CODE: RECADD ( rec# rlen offset blk -- offset blk )             
\ Calc record offset and block given start offset & blk,        
\ record len & record #.                                        
  S U MOV  1024 # 0 MOV  2 3) 0 SUB  2 2 XOR                    
  4 3) 1 MOV  1 DIV  6 3) 0 CMP  0>                             
  IF   6 3) 0 MOV  1 MUL  0 2 3) ADD                            
  ELSE 0 6 3) SUB  U ) INC  0 # 2 3) MOV                        
                                                                
                                                                
       1024 # 0 MOV  2 2 XOR                                    
       1 DIV  0 1 MOV  6 3) 0 MOV                               
       2 2 XOR  1 DIV  0 U ) ADD                                
       2 0 MOV  4 3) MUL  0 2 3) MOV                            
  THEN                                                          
  0 POP 1 POP 4 # S ADD  1 PUSH 0 PUSH NEXT                     
                                                                
CODE: DOFFBLK ( dirrec# -- offset blk )                         
\ Calc directory record# offset & block.                        
  0 POP  96 # 0 CMP  0< NOT                                     
  IF DIRBLK U MOV 2 # U ADD 96 # 0 SUB                          
  ELSE 48 # 0 CMP 0< NOT                                        
     IF DIRBLK U MOV U INC 48 # 0 SUB                           
     ELSE DIRBLK U MOV                                          
     THEN                                                       
                                                                
  THEN 21 # 1 MOV  1 IMUL  0 PUSH  U PUSH                       
  NEXT                                                          
HEAD: DFIELD ( offset <name> -- )                               
\ Define directory field.                                       
\ At run time: record# <fieldname> -- addr \ in buffer          
T: CREATE C, \ PFA==>[offset]                                   
   DOES> C@ SWAP DOFFBLK BLOCK + + T;                           
                                                                
\ Disk directory fields.                                        
 0 DFIELD FILE-NAME  \ 12 ASCII characters                      
12 DFIELD FILE-TYPE  \ 0=fixed,1=var,2=overlay                  
13 DFIELD FILE-START \ start of file on disk                    
15 DFIELD FILE-END   \ end of file on disk                      
17 DFIELD FILE-#REC  \ max # records                            
19 DFIELD FILE-RLEN  \ max record length                        
20 DFIELD FILE-SLEN  \ status record length                     
\ BVSA>OFFBLK FILE:                                             
                                                                
CODE: BVSA>OFFBLK ( vsa -- offset blk )                         
\ Compute block and offset in file b.                           
  0 POP  BLOVSA # 0 SUB  6 # 1 MOV  2 2 XOR                     
  BEGIN 0 SHR 2 RCR B LOOP                                      
  2 SHL  2 SHL  2 PUSH  0 PUSH NEXT                             
                                                                
: FILE: ( <filename> -- file# )                                 
\ Given *file name find file#.                                  
  LSCAN 12 BL FILL  BL WORD COUNT LSCAN SWAP CMOVE              
  BLK @ >R >IN @ >R -1                                          
  140 0 DO LSCAN 12 I FILE-NAME -TEXT                           
           NOT IF DROP I LEAVE THEN                             
        LOOP DUP 0< ?UNRAVEL                                    
  R> >IN <!> R> BLK <!> ; IMMEDIATE                             
\ >FILE FILE<                                                   
: >FILE ( seg file# -- )                                        
\ Send data at memory segment to disk *file                     
\ ie. HBUF-SEG @ FILE: STARBLT >FILE.                           
  FILE-START 2@ SWAP OVER - 1+ MEM>DSK ;                        
                                                                
                                                                
: FILE< ( seg file# -- )                                        
\ Get data from disk file to memory                             
\ ie. HBUF-SEG @ FILE: STARBLT FILE<.                           
  FILE-START 2@ SWAP OVER - 1+ MEM<DSK ;                        
                                                                
                                                                
                                                                
                                                                
                                                                
\ |REC ?-RECINBUF ?BMOUNT                                       
HEAD: ?BMOUNT ( -- )                                            
T: ?AFILE IF MOUNTB THEN T;                                     
                                                                
HEAD: |REC ( file# rec# rlen start-vsa -- addr )                
\ Read record from disk and set it as the last record.          
T: ?BMOUNT                                                      
   BVSA>OFFBLK       ( file# rec# rlen off blk -- )             
   4 PICK LRECORD# <!>                                          
   RECADD            ( file# off blk -- )                       
   <BLOCK> + DUP LBADD <!>                                      
   SWAP LFILE# <!> T;                                           
                                                                
HEAD: ?-RECINBUF ( file# rec# -- file# rec# t/f )               
\ Is record not in buffer?.                                     
T: OVER LFILE# @ = OVER LRECORD# @ = AND NOT T;                 
: @RECORD ( file# record# -- addr )                             
\ Get record buffer address.                                    
  ?-RECINBUF                                                    
  IF OVER FILE-RLEN C@    ( file# rec# rlen -- )                
     3 PICK FILE-START @  ( file# rec# rlen start-vsa -- )      
     |REC                                                       
  ELSE 2DROP LBADD @      \ last = current record               
  THEN ;                                                        
                                                                
                                                                
: AFIELD ( file# offset len <name> -- )                         
\ Define field in fixed record length file.                     
\ At runtime: ( -- addr ) buffer address.                       
\ PFA==>[file#][offset][len][rlen][fstart]                      
  CREATE ROT DUP C, >R ( -- file#)                              
         SWAP C, C,  I FILE-RLEN C@ C,                          
         R> FILE-START @ ,                                      
  DOES>  >R  \ I C@ FILE# @ = NOT                               
 (   IF UNRAVEL )                                               
 (   ELSE ) FILE# @ RECORD# @ ?-RECINBUF                        
      IF I 3 + C@ I 4 + @                                       
                 ( file# rec# rlen start-vsa -- pfa)            
         |REC    ( addr -- )                                    
      ELSE 2DROP LBADD @ ( addr -- )                            
      THEN                                                      
      R> 1+ C@ +        \ add offset                            
  ( THEN) ;                                                     
                                                                
                                                                
CODE: IFLDADR ( pfa -- addr )                                   
\ Compute ifield offset given pfa of field.                     
  U POP  0 0 XOR  1 3) 0 MOV B                                  
  IBFR 3 + # 0 ADD  0 PUSH NEXT                                 
                                                                
: IFIELD ( file# offset len <name> -- )                         
\ Define instance field.                                        
\ runtime: -- addr \ in current instance                        
\ PFA==>[file#][offset][len]                                    
  CREATE ROT C, SWAP C, C,                                      
  DOES>                                                         
\ Leave in for debugging.                                       
\  DUP >R C@ \ if instance field isn't global ck for err        
\  IF FILE# @  I C@ = NOT                                       
\     ?UNRAVEL                                                  
\  THEN                                                         
\  R>                                                           
    IFLDADR ;                                                   
                                                                
\ MEMORY - IFIELD - Global Instance Fields                      
\                                                               
\ class file#  offset len          field name                   
       0         0     3   IFIELD  INST-SIB                     
       0         3     3   IFIELD  INST-PREV                    
       0         6     3   IFIELD  INST-OFF                     
       0         9     1   IFIELD  INST-CLASS                   
       0        10     1   IFIELD  INST-SPECIES                 
       0        11     2   IFIELD  INST-QTY  \ not in header    
       0        13     2   IFIELD  INST-X    \ not in header    
       0        15     2   IFIELD  INST-Y    \ not in header    
                                                                
HEAD: !INST-SIB   T: ( d --) INST-SIB     1.5! T;               
HEAD: !INST-PREV  T: ( d --) INST-PREV    1.5! T;               
                                                                
                                                                
HEAD: !INST-OFF   T: ( d --) INST-OFF     1.5! T;               
HEAD: !INST-CLASS T: ( c --) INST-CLASS     C! T;               
: !INST-SPECIES ( c --) INST-SPECIES   C! ;                     
HEAD: @INST-SIB   T: ( -- d) INST-SIB     1.5@ T;               
HEAD: @INST-PREV  T: ( -- d) INST-PREV    1.5@ T;               
HEAD: @INST-OFF   T: ( -- d) INST-OFF     1.5@ T;               
: @INST-CLASS   ( -- c) INST-CLASS     C@ ;                     
: @INST-SPECIES ( -- c) INST-SPECIES   C@ ;                     
                                                                
                                                                
\ i = instance record address, 24 bit address                   
                                                                
CODE >C ( d -- , { -- i } )                                     
\ Move d from parm stack to the context stack.                  
  CXSP U MOV  0 POP  0 2 3) MOV B                               
  U ) POP 3 # CXSP SUB NEXT                                     
\ C> CI CDROP                                                   
CODE C> ( -- d , { i -- } )                                     
\ Move i from context stack to parm.                            
  3 # CXSP ADD  CXSP U MOV  U ) PUSH  0 0 XOR                   
  2 3) 0 MOV B  0 PUSH  NEXT                                    
                                                                
CODE CI ( { i -- i } , -- d )                                   
\ Copy top of cstack to parm stack.                             
  CXSP U MOV  3 3) PUSH  0 0 XOR 5 3) 0 MOV B                   
  0 PUSH NEXT                                                   
                                                                
: CDROP ( { i -- } )                                            
\ Drop top item from cstack.                                    
  C> 2DROP ;                                                    
                                                                
                                                                
: CI' ( { i i' -- i i' } , -- d )                               
\ Copy 2nd cstack to parm.                                      
  C> CI 2SWAP >C ;                                              
                                                                
: CJ ( { i i' i" -- i i' i" } , -- d )                          
\ Copy 3rd to parm.                                             
  C> CI' 2SWAP >C ;                                             
                                                                
: COVER ( { i i' -- i i' i } ) CI' >C ;                         
                                                                
CODE CDEPTH ( -- u )                                            
\ Put a count of the number of items on the context stack.      
  END-CX # 0 MOV  CXSP 0 SUB  3 # 1 MOV                         
  1 DIV B 0 PUSH NEXT                                           
                                                                
                                                                
: ?NULL ( -- t )                                                
\ Is the current instance null?.                                
  CI D0= ;                                                      
: ?-NULL ( -- t )                                               
\ Is the current instance not null?.                            
  ?NULL NOT ;                                                   
                                                                
: ?CHILD ( -- t )                                               
\ Does this instance have a child?.                             
  @INST-OFF  D0= NOT ;                                          
                                                                
                                                                
HEAD: ?ONLY ( -- t )                                            
\ Is this the only instance in the current container?           
T: CI @INST-SIB D= T;                                           
                                                                
: !IADDR ( i -- )                                               
\ Store instance address for current instance.                  
  IADDR <1.5!> ;                                                
CODE: @[IOFF] ( -- offset )                                     
\ Get offset of current instance in instance cache table.       
  [IOFF] 0 MOV 0 PUSH NEXT                                      
EXIT HEX                                                        
CODE: LWSCAN ( seg offset ct pattern -- offset 1 or 0 )         
\ Long search for matching word.                                
  0 POP  1 POP  1 1 OR 0= IF 4 # S ADD 1 PUSH ELSE              
  2 ES SSG  W U MOV  W POP  ES POPS                             
  F2 C, SCAS  W DEC W DEC ES SEG W ) 0 CMP 0=                   
  IF W PUSH 1 # 1 MOV THEN 1 PUSH                               
  U W MOV  2 ES LSG  THEN NEXT                                  
DECIMAL                                                         
                                                                
\ IBFR>ICACHE ICACHE>IBFR BVA>BUF                               
                                                                
HEAD: IBFR>ICACHE ( -- )                                        
\ Write current instance to icache.                             
T: @DS IBFR $SEG @ $OLD @  LENINST @ LCMOVE T;                  
                                                                
                                                                
HEAD: ICACHE>IBFR ( -- )                                        
\ Write current instance to IBFR.                               
T: $SEG @ $OLD @ @DS IBFR  LENINST @ LCMOVE T;                  
                                                                
HEAD: BVA>BUF                                                   
T: ?BMOUNT                                                      
    VA>BUF T;                                                   
                                                                
                                                                
CODE PRIORITIZE ( offset -- offset' )                           
\ Exchange the current offset with the one immediately          
\ above it.                                                     
  0 POP  0 0 OR  0= NOT                                         
  IF 0 U MOV  2 # U SUB                                         
     ES PUSHS                                                   
     LOISEG  PUSH  ES POPS  {LXCHG} CALL                        
     $LOCSEG PUSH  ES POPS  {LXCHG} CALL                        
     U SHR 0 SHR                                                
     HIISEG  PUSH  ES POPS  {LCXCHG} CALL                       
     ES POPS   U SHL U 0 MOV                                    
  THEN 0 PUSH NEXT                                              
                                                                
                                                                
HEAD: ITLEN ( addr -- len)                                      
\ Given disk buffer address of an instance, compute             
\ it's total length.                                            
T: DUP 9 + C@   ( addr class --)                                
   DUP 48 = IF   DROP 11 + C@ 1+        ( addr slen --)         
           ELSE SWAP DROP FILE-SLEN C@ ( addr slen --)          
           THEN                                                 
   IHEADLEN + T;                                                
                                                                
                                                                
HEAD: POINT>I ( offset -- )                                     
\ Given inst table offset focus on the instance in              
\ that location.                                                
T: [IOFF] <!> $SEG @                                            
   $LOCSEG @ @[IOFF] L@   \ compute string address              
   DUP $OLD <!> L@ LENINST <!>                                  
   LOISEG @ @[IOFF] L@                                          
   HIISEG @ @[IOFF] 2/ LC@ !IADDR T;                            
                                                                
                                                                
HEAD: ?INCACHE ( i -- offset 1 or 0 )                           
\ Given instance addr search for a match in the                 
\ cache look-up table.                                          
T: QTYINST @ IF                                                 
  SWAP     ( hi-byte lo-word -- )                               
  >R                                                            
  LOISEG @ 0 QTYINST @ I LWSCAN ( hi-byte offset.1 or 0 --)     
  IF DUP 2/ HIISEG @ SWAP LC@ ROT = NOT                         
     IF LOISEG @ SWAP 2+ QTYINST @ OVER 2/ - I LWSCAN           
     ELSE 1 THEN                                                
  ELSE DROP 0                                                   
  THEN R> DROP ELSE 2DROP 0 THEN T;                             
                                                                
                                                                
HEAD: ?UPDINST ( seg $adr -- t/f )                              
\ Update flag for instance set?                                 
T: 2+ LC@ T;                                                    
                                                                
HEAD: ?IN$LOC ( $offset -- offset t/f )                         
\ Given string offset look for the location in the              
\ string location table.                                        
T: >R $LOCSEG @ 0 QTYINST @ R> LWSCAN  ( offset.1/0 -- ) T;     
                                                                
                                                                
HEAD: ?UPDATE>CACHE ( -- )                                      
\ Write instance from IBFR to icache if update flag is set.     
T: IBFR 2+ C@                                                   
   IF IBFR>ICACHE 0 IBFR 2+ <C!> NULL !IADDR THEN T;            
                                                                
                                                                
HEAD: ?UPD>DISK ( -- )                                          
\ Write instance from icache to disk if update flag is set.     
T: $SEG @ $OLD @ ?UPDINST                                       
  IF $SEG @ $OLD @ 3 + @DS IADDR 1.5@ BVA>BUF ?UPDATE           
  LENINST @ 3 - LCMOVE  0 $SEG @ $OLD @ 2+ LC! THEN T;          
                                                                
                                                                
HEAD: -LINST ( -- )                                             
\ Delete last instance from cache & compress.                   
T: QTYINST @ 1- 2* POINT>I ?UPD>DISK  ( -- \ maybe update)      
  -1 QTYINST <+!>  LENINST @ NEGATE $FREE <+!>                  
     0  LOISEG @ @[IOFF] L! \ clear iaddr entry                 
  9999 $LOCSEG @ @[IOFF] L! \ clear $ pointer entry             
  $OLD @ $NEW <!>           \ initial destination               
  BEGIN                                                         
    $OLD @ LENINST @ + ( $offset --)                            
    ?IN$LOC      ( offset t/f -- \ look for entry in $loc)      
  WHILE                                                         
    POINT>I                                                     
    $SEG @ $OLD @ OVER $NEW @ LENINST @ LCMOVE                  
    $NEW @ $LOCSEG @ @[IOFF] L!                                 
    LENINST @ $NEW <+!>     \ update destination pointer        
  REPEAT T;                                                     
                                                                
                                                                
HEAD: ?$COLLECT ( -- )                                          
\ Compress string space.                                        
T: BEGIN $MAX @ $FREE @ - 273 <    \ string space full?         
   WHILE -LINST REPEAT T;                                       
                                                                
                                                                
58 0 12 AFIELD 1BTN                                             
                                                                
: AFIELD: ( file# offset len <name> -- )                        
\ Headless afield definer.                                      
  HEAD: [ ' 1BTN CFA @ ] LITERAL , \ ***patched later***        
  ROT DUP C, >R ( -- file#)                                     
  SWAP C, C, I FILE-RLEN C@ C, R> FILE-START @ , ;              
                                                                
: IFIELD: ( file# offset len <name> -- )                        
\ Headless ifield definer.                                      
\ PFA: file#, offset, len.                                      
  HEAD: [ ' INST-SIB CFA @ ] LITERAL ,                          
  ROT C, SWAP C, C, ;                                           
                                                                
58 72 1 AFIELD: #BTN                                            
                                                                
HEAD: DISK>IBFR ( i -- )                                        
\ Install instance in icache and ibfr. Possibly force           
\ compression of cache.                                         
T: ?$COLLECT           ( -- \ maybe collect $ space)            
   2DUP !IADDR                                                  
   BVA>BUF DUP ITLEN    ( addr tlen -- )                        
   DUP 3 + DUP IBFR !  ( addr tlen ilen -- \ store inst len)    
   LENINST <!>                                                  
   IBFR 3 + SWAP CMOVE \ move inst>ibfr                         
   0 IBFR 2+ <C!>      \ clr update flag                        
   QTYINST @ 2* [IOFF] <!>                                      
   1 QTYINST <+!>      \ allocate iaddr slot                    
   IADDR 1.5@                                                   
   HIISEG @ @[IOFF] 2/ LC!  \ install iaddr hibyte              
   LOISEG @ @[IOFF]    L!   \ install iaddr loword              
   $FREE @ $OLD <!>                                             
   LENINST @ $FREE <+!>   \ allocate $                          
   $OLD @ $LOCSEG @ @[IOFF] L! \ install $ pointer              
   IBFR>ICACHE T;         \ install instance in cache           
                                                                
                                                                
: SET-CURRENT ( {i --i} )                                       
\ Move instance to instance buffer and mark it as the           
\ current  instance.                                            
  CDEPTH 0>         \ is something is on the stack?             
  IF ?UPDATE>CACHE  \ if prev instance updated, write back      
    ?-NULL          \ if valid instance                         
    IF CI ?INCACHE      ( offset.1 or 0 -- )                    
       IF PRIORITIZE POINT>I ICACHE>IBFR \ from cache           
       ELSE CI DISK>IBFR   \ get instance from disk             
       THEN                                                     
       @INST-CLASS   FILE# <!>   \ set up ca file pointer       
       @INST-SPECIES RECORD# <!> \ set up ca record pointer     
    THEN                                                        
  THEN ;                                                        
                                                                
                                                                
: ICLOSE ( {i i' -- i} )                                        
\ Close the current container leaving it as the                 
\ current instance.                                             
  ?UPDATE>CACHE CDROP ( CDEPTH 0< ?UNRAVEL )                    
  COVER ?-NULL                                                  
  IF SET-CURRENT @INST-OFF ELSE NULL THEN                       
  1STOFF <1.5!> CDROP SET-CURRENT ;                             
                                                                
                                                                
: >C+S ( d { -- i } )                                           
  >C SET-CURRENT ;                                              
                                                                
                                                                
: @>C+S ( dvar { -- i } )                                       
  1.5@ >C+S ;                                                   
                                                                
                                                                
: IOPEN ( {i -- i i'} )                                         
\ Push the 1st offspring of i onto the context stack            
\ making it the current instance and i the current              
\ container.                                                    
  ( ?NULL ?UNRAVEL )                                            
  @INST-OFF 2DUP 1STOFF <1.5!> >C+S ;                           
                                                                
                                                                
: CCLR ( -- )                                                   
\ Initialize cstack pointer.                                    
  ?UPDATE>CACHE END-CX CXSP <!> CXS 120 0 FILL ;                
                                                                
                                                                
HEAD: 1STCHILD ( -- d )                                         
\ Put 1st offspring of current container onto parm stack.       
T: 1STOFF 1.5@ T;                                               
                                                                
                                                                
: ?LAST ( -- t )                                                
\ Is this the last instance in the ring?                        
  @INST-SIB  1STCHILD D= ;                                      
                                                                
: ?FIRST ( -- t )                                               
\ Is this the first instance in the ring?                       
  CI 1STCHILD D= ;                                              
                                                                
: >C+ ( d { i -- i i' } )                                       
\ Perform inits for manual [vs. IOPEN] child positioning.       
  SET-CURRENT IOPEN CDROP >C ;                                  
                                                                
: INEXT ( {i i' -- i i"} )                                      
\ Replace the current instance with it's next sibling.          
  ?-NULL IF @INST-SIB CDROP >C+S THEN ;                         
                                                                
: IPREV ( {i i' -- i i"} \ replace the current instance with)   
        \ it's previous sibling                                 
  ?-NULL IF @INST-PREV CDROP >C+S THEN ;                        
                                                                
: IFIRST ( {i i' -- i i"} \ replace the current instance with)  
         \ the first instance in the current container          
  CDROP 1STCHILD >C+S ;                                         
                                                                
: ILAST  ( {i i' -- i i"} \ replace the current instance with)  
  ( the last instance in the current container) IFIRST IPREV ;  
                                                                
: VCLR ( -- \ initialize cstack pointer )                       
  END-V VSP <!> ;                                               
                                                                
CODE >V ( u -- ,{{ -- u }}\ move u from parm stack to)          
        \ the vector stack                                      
  VSP U MOV  U ) POP  2 # VSP SUB NEXT                          
                                                                
CODE V> ( -- u , {{u --}} \ move u from vector stack to parm)   
  2 # VSP ADD  VSP U MOV  U ) PUSH NEXT                         
                                                                
code: VI ( {{u -- u}} , -- u \ copy top of vstack to parm stack)
  VSP U MOV  2 3) PUSH NEXT                                     
                                                                
                                                                
                                                                
                                                                
                                                                
HEAD: IC>DISK                                                   
T: ( -- \ update contents of instance cache to disk)            
  ?UPDATE>CACHE QTYINST @ ?DUP                                  
  IF 0 DO I 2* POINT>I ?UPD>DISK LOOP SET-CURRENT THEN T;       
                                                                
' IC>DISK 'SVBUF ! \ SAVE-BUFFERS PREFIX                        
' ICINIT  'MTBUF ! \ EMPTY-BUFFERS PREFIX                       
: SAVE-BUFFERS SAVE-BUFFERS INIT ;                              
: FLUSH SAVE-BUFFERS EMPTY-BUFFERS ;                            
: IINSERT ( extracted-instance destination-container -- \   )   
                                                                
                                                                
                                                                
\ Insert the extracted instance into the destination instance   
\ as it's 1st offspring.                                        
  >C+S ?CHILD                                                   
  IF @INST-OFF 2SWAP !INST-OFF       \ link to new child        
     IOPEN !INST-SIB CI INEXT        \ link new to sib          
     @INST-PREV 2SWAP !INST-PREV     \ link sib to new          
     IPREV !INST-PREV                \ link new to prev         
     CI IPREV !INST-SIB              \ link prev to new         
  ELSE !INST-OFF                     \ link to new child        
       IOPEN CI !INST-SIB            \ link new to sib          
       CI !INST-PREV                 \ link new to prev         
  THEN CDROP ICLOSE ;                                           
                                                                
                                                                
: <INSERT ( extracted-instance dest-sibling -- \   )            
        \ insert the extracted instance before  the dest.       
        \ sibling                                               
  >C+S                                                          
  @INST-PREV 2SWAP !INST-PREV                                   
  CI IPREV !INST-SIB  !INST-PREV                                
  CI IPREV !INST-SIB ICLOSE ;                                   
                                                                
                                                                
: >INSERT ( extracted-instance dest-sibling -- \   )            
        \ insert the extracted instance after  the dest.        
        \ sibling                                               
  >C+S @INST-SIB ICLOSE <INSERT ;                               
                                                                
                                                                
: IEXTRACT ( {i i' -- i i'sibling}, --d  \ extract current   )  
        \ instance from the tree leaving it's instance address  
        \ on the parameter stack and it's former sibling as     
        \ the new current instance.                             
   CI ?ONLY                                                     
   IF ICLOSE NULL !INST-OFF IOPEN                               
   ELSE                                                         
      ?FIRST                                                    
      IF @INST-PREV @INST-SIB ICLOSE !INST-OFF IOPEN            
         !INST-PREV CI IPREV !INST-SIB INEXT                    
      ELSE @INST-SIB IPREV !INST-SIB                            
           CI INEXT !INST-PREV                                  
      THEN                                                      
   THEN ;                                                       
                                                                
                                                                
HEAD: NEWSPACE                                                  
T: ( -- field-addr \ instance free space pointer     )          
  VANEWSPACE VA>BUF T;                                          
                                                                
: @NEWSPACE NEWSPACE 1.5@ ;                                     
: !NEWSPACE NEWSPACE 1.5! ;                                     
                                                                
HEAD: +!NEWSPACE T: @NEWSPACE ROT M+ !NEWSPACE T;               
                                                                
HEAD: MAXSPACE ( -- field-addr \ limit to free space)           
T: VANEWSPACE 3. D+ VA>BUF T;                                   
                                                                
HEAD: BLKSPACE                                                  
T: ( -- spc \ compute bytes from newspace to end)               
  ( block) @NEWSPACE VA>BLK DROP 1024 SWAP - T;                 
                                                                
                                                                
CASE FLD@ 1 IS C@ 2 IS @ 3 IS 1.5@ OTHERS @                     
CASE FLD! 1 IS C! 2 IS ! 3 IS 1.5! OTHERS !                     
                                                                
                                                                
: IFLD@ ( field-pfa -- n , {n -- n} \ fetch the contents )      
        \ of the instance or common-attribute field indicated   
        \ by field-pfa for the current instance.                
        \ Handles 1,2,3 & 4 byte fields.                        
  DUP 2+ C@   ( pfa len --)                                     
  SWAP EXECUTE SWAP FLD@ ;                                      
                                                                
                                                                
: IFLD! ( val field-pfa -- n , {n -- n} \ store val into )      
        \ the field specified by field-pfa for the current      
        \ instance.                                             
  DUP 2+ C@   ( pfa len --)                                     
  SWAP EXECUTE SWAP FLD! ;                                      
                                                                
                                                                
HEAD: ?FLD= ( pfa-field u -- field-pfa u t \ test if value)     
  \ equals the field contents in the current instance.          
  \ Byte and word length fields are supported.                  
  T: OVER IFLD@ OVER = T;                                       
                                                                
                                                                
: ?CLASS/SPECIES ( class species -- class species t)            
  OVER DUP 0= SWAP @INST-CLASS = OR                             
  OVER DUP 0= SWAP @INST-SPECIES = OR AND ;                     
                                                                
                                                                
HEAD: ?CHOICE ( -- t) T: '?CHOICE   @EXECUTE T;                 
HEAD: ?EXIT   ( -- t) T: '?EXIT     @EXECUTE T;                 
HEAD: TRAVERS ( -- )  T: 'TRAVERS   @EXECUTE T;                 
: MAP     ( -- )  'MAP       @EXECUTE ;                         
HEAD: DUP@>V! ( pfa adr -- ) T: DUP @ >V <!> T;                 
HEAD: V>SWAP! ( adr -- ) T: V> SWAP <!> T;                      
                                                                
                                                                
: SELECT ( -- t \ use the current choice function to find)      
  \ an instance via the current traversal function or until     
  \ the current exit condition is satisfied.                    
  \ Leave a truth value to show if a match was found.           
  0 >V                        \ clear traversal flag            
  BEGIN                                                         
    ?CHOICE ?EXIT OR NOT      \ test for match or end           
  WHILE                                                         
    TRAVERS                   \ to next instance in ring        
    V> DROP 1 >V              \ set traversal flag              
  REPEAT                                                        
  ?EXIT NOT V> DROP ;         \ drop traversal flag             
                                                                
                                                                
: ?>FIRST ( -- t \ has the first instance been reached via a)   
  \ traversal? Assumes traversal flag on the vector stack.      
  VI ?FIRST AND ?NULL OR ;                                      
                                                                
                                                                
: SELECT-2DROP ( u u pfa-?choice -- t)                          
  '?CHOICE          DUP@>V! \ push/install choice function      
  ' ?>FIRST '?EXIT  DUP@>V! \ push/install exit   function      
  ' INEXT  'TRAVERS DUP@>V! \ push/install traversal function   
  SELECT                                                        
  'TRAVERS   V>SWAP!     \ restore prev traversal function      
  '?EXIT     V>SWAP!     \ restore prev exit      function      
  '?CHOICE   V>SWAP!     \ restore prev choice    function      
  >R 2DROP R> ;                                                 
HEAD: 3SELECTDROP ( u u u pfa-?test -- t)                       
T:  SELECT-2DROP >R DROP R> T;                                  
                                                                
                                                                
HEAD: =FIND                                                     
T: ( pfa-field u -- t \ select instance for which u is)         
  \ equal to the contents of the field. See SELECT.             
  ' ?FLD= SELECT-2DROP T;                                       
                                                                
: IFIND   ( class spec  -- t ) ' ?CLASS/SPECIES SELECT-2DROP ;  
                                                                
                                                                
HEAD: MAP>ROOT ( { n n' -- n n'} \ MAP the offspring of n')     
  \ in leaf to root order.                                      
T: ?CHILD IF                                                    
  IOPEN BEGIN MYSELF MAP TRAVERS ?EXIT UNTIL ICLOSE             
  THEN T;                                                       
                                                                
                                                                
HEAD: MAP>LEAF                                                  
T:  ( { n n' -- n n'} \ MAP n' and the offspring of n')         
  \ from root to leaf in a depth first order.                   
  MAP                                                           
  ?CHILD IF                                                     
  IOPEN BEGIN MYSELF TRAVERS ?EXIT UNTIL ICLOSE                 
  THEN T;                                                       
                                                                
                                                                
: MAKE1ST ( { i i' -- i i' } \ make i' 1st child of i)          
  ?FIRST NOT IF IEXTRACT CI' IINSERT IFIRST THEN ;              
\ INST-SPECIES is used for length of status field in free list  
HEAD: EXTRACTED>INACTIVE                                        
T: ( i len -- move extracted instance to )                      
  \ inactive. Self organizing so that box moved to beginning    
  \ of list.                                                    
  INACTIVE >C+S                                                 
  ?CHILD IF IOPEN ' INST-SPECIES SWAP =FIND                     
            IF MAKE1ST   \ organize                             
               CI                                               
            ELSE CI'                                            
            THEN ICLOSE                                         
         ELSE DROP CI                                           
         THEN IINSERT ICLOSE T;                                 
                                                                
                                                                
: >INACTIVE ( extracted-instance -- \ move extracted instance)  
  \ to inactive instance list                                   
  2DUP >C+S                                                     
  IBFR @ 3 - IHEADLEN - ( slen --)                              
  DUP  !INST-SPECIES  CDROP \ ICLOSE                            
  EXTRACTED>INACTIVE ;                                          
                                                                
                                                                
HEAD: (IDELETE) ( -- \ delete the current instance)             
T: IEXTRACT >INACTIVE T;                                        
                                                                
                                                                
: IDELETE ( { n n' -- n n'sib } \ delete the current instance)  
          \ and all of it's contents, replacing it with it's    
          \ sibling as the current instance                     
  ' (IDELETE)  'MAP   DUP@>V!                                   
  ' ?NULL      '?EXIT DUP@>V!                                   
  ' NOP     'TRAVERS  DUP@>V!                                   
  MAP>ROOT  \ delete offspring                                  
  MAP       \ delete root                                       
  'TRAVERS   V>SWAP!                                            
  '?EXIT     V>SWAP!                                            
  'MAP       V>SWAP! ;                                          
                                                                
                                                                
HEAD: SELECT-MAP                                                
T:           ( pfa-?choice pfa-?exit pfa-traverse pfa-map )     
  \ start with the first instance in the current container      
  \ and apply the mapping function to each instance chosen      
  \ by pfa-select. This routine is re-entrant.                  
  'MAP      DUP@>V!                                             
  'TRAVERS  DUP@>V!                                             
  '?EXIT    DUP@>V!                                             
  '?CHOICE  DUP@>V!                                             
  IFIRST        \ start with the first instance                 
  BEGIN SELECT IF MAP TRAVERS  ?FIRST ELSE 1 THEN UNTIL         
  '?CHOICE  V>SWAP!                                             
  '?EXIT    V>SWAP!                                             
  'TRAVERS  V>SWAP!                                             
  'MAP      V>SWAP! T;                                          
                                                                
                                                                
: ALL ( pfa-map -- \ apply mapping function to all items in)    
  \ the current container. This word replaces ALL[ ]ALL.        
  >R ' ?-NULL  ' ?>FIRST ' INEXT R> SELECT-MAP ;                
                                                                
                                                                
: EACH ( pfa-?choice pfa-map -- \ apply mapping function)       
  \ to each instance found using pfa-?choice in the current     
  \ container. This word has a different function in OHS1.0     
  >R  ' ?>FIRST  ' INEXT R> SELECT-MAP ;                        
  ' UNRAVEL 'THROW-AWAY <!>                                     
                                                                
                                                                
HEAD: THROW-AWAY ( -- \ purge old instances )                   
T:  'THROW-AWAY @EXECUTE T;                                     
                                                                
                                                                
: NULLPOINTERS ( -- \ set pointers for CI to null)              
  NULL !INST-SIB NULL !INST-PREV NULL !INST-OFF ;               
                                                                
                                                                
HEAD: CHILDEXTRACT ( -- d )                                     
\ extract child of CI if present or extract CI                  
T: ?CHILD IF IOPEN IEXTRACT ICLOSE ELSE IEXTRACT THEN T;        
                                                                
                                                                
HEAD: TRY-INACTIVE                                              
T: ( class species len -- class species len ,    )              
  \                                   { -- extracted-instc}     
  \ allocate space for an instance by searching though the      
  \ inactive instance container for a length match              
  INACTIVE >C+S ?CHILD                                          
  IF IOPEN ' INST-SPECIES OVER =FIND \ look for length match    
   IF ?RECYCLED <ON> MAKE1ST CHILDEXTRACT ELSE NULL THEN ICLOSE 
  ELSE NULL                                                     
  THEN ICLOSE >C T;                                             
                                                                
                                                                
HEAD: NEWFRAGMENT ( -- \ build fragment instance &  )           
T:  \ advance instance free space pointer                       
  BLKSPACE IHEADLEN >                                           
  IF BLKSPACE IHEADLEN - 1-  ( $len --)                         
     @NEWSPACE VA>BUF >R I 11 + C! \ store string length byte   
     48 R> 9 + C!                 \ store string object class   
     @NEWSPACE >C+S                                             
     NULLPOINTERS CI ICLOSE >INACTIVE                           
  THEN BLKSPACE +!NEWSPACE T;                                   
                                                                
                                                                
HEAD: ?>MAXSPACE                                                
T: ( slen -- slen t \ has all space been allocated?)            
  DUP >R MAXSPACE 1.5@ @NEWSPACE R> 0 D+ D< T;                  
                                                                
                                                                
HEAD: TRY-NEWSPACE                                              
T:      ( slen --slen , { -- extracted-instance } \ )           
               \ allocate new instance                          
  ?>MAXSPACE                                                    
  IF NULL >C                                                    
  ELSE BLKSPACE                      ( slen space-in-blk -- )   
       OVER  IHEADLEN +              ( slen spc slen+h -- )     
       < IF NEWFRAGMENT THEN                                    
       @NEWSPACE >C DUP IHEADLEN + +!NEWSPACE                   
       ?>MAXSPACE IF CDROP NULL >C THEN                         
  THEN T;                                                       
                                                                
                                                                
HEAD: GET-NEW-INSTANCE ( len -- len,{ --i})                     
T:  \ find space for an instance of                             
  \ length len and leave it on the                              
  \ context stack.                                              
  BEGIN                                                         
    ?RECYCLED <OFF>                                             
    ?REUSE @ IF TRY-INACTIVE ELSE TRY-NEWSPACE THEN             
    ?NULL IF CDROP                                              
             ?REUSE @ IF TRY-NEWSPACE ELSE TRY-INACTIVE THEN    
             ?NULL IF ( beep beep beep) THROW-AWAY THEN         
          THEN                                                  
    ?NULL                                                       
  WHILE                                                         
    CDROP                                                       
  REPEAT T;                                                     
                                                                
CASE SET?REUSE ( pfa-?reuse class -- \ select where object is)  
 \ to come from based on class: ON=from INACTIVE, OFF=new       
  11 IS <ON>     41 IS <ON> \ box AND RUINS                     
  14 IS <ON>     26 IS <ON> \ bank-trans AND MINERALS           
  68 IS <ON>     28 IS <ON> \ creature AND ARTIFACTS            
  56 IS <ON>     36 IS <ON> \ scroll-text AND EVALUATIONS       
  40 IS <ON>     43 IS <ON> \ specimens and BIO-DATA            
  24 IS <ON>          25 IS <ON> \ stars and vessels            
  67 IS <ON>                     \ regions                      
OTHERS <OFF>                                                    
                                                                
: VICREATE ( len -- d-iaddr \ create a)                         
  \ STRING object with given len.                               
  \ The byte following INST-SPECIES                             
  \ is the count byte for the string.                           
  \ STRING is id# 48.                                           
  ?REUSE <OFF>               ( -- \ create from newspace)       
  DUP 254 > ?unravel ( ABORT" string too long")                 
  1+ GET-NEW-INSTANCE 1-   ( slen -- , { i --})                 
  CI VA>BUF                ( slen addr -- , { i --})            
  >R I 11 + C!             ( -- adr , " \ save len)             
  48 R> 9 + C!             ( -- , " \ save class)               
  SET-CURRENT                                                   
  NULLPOINTERS CI ICLOSE ;                                      
                                                                
                                                                
: ICREATE ( class species -- d-iaddr )                          
  \ / create a new instance of class                            
  \ and species.                                                
  ?REUSE 3 PICK SET?REUSE                                       
  OVER FILE-SLEN C@ GET-NEW-INSTANCE DROP                       
  ?RECYCLED @ NOT                                               
  IF   CI VA>BUF DUP >R 10 + C! R> 9 + C! SET-CURRENT           
  ELSE SET-CURRENT !INST-SPECIES !INST-CLASS                    
  THEN                                                          
  NULLPOINTERS CI ICLOSE ;                                      
                                                                
                                                                
: *CREATE ( class species count -- \ create count instances)    
  \ of class, species and append them to contents of the        
  \ current container.  CSTACK is left on the last created      
  \ instance.                                                   
  0 DO 2DUP ICREATE ?NULL                                       
       IF CI' IINSERT IFIRST                                    
       ELSE 1STCHILD <INSERT                                    
       THEN                                                     
    LOOP ILAST 2DROP ;                                          
                                                                
                                                                
HEAD: .DRJ                                                      
T: ( d -- \ display rt just #)  2 SPACES 5 D.R T;               
                                                                
                                                                
\ HEAD: .INM                                                    
\ T: ( d -- \ display instance addr & name for current)         
\   >C+S ?-NULL                                                 
\          IF @INST-CLASS FILE-NAME 12 TYPE CI .DRJ             
\          ELSE 0. .DRJ ." <NULL>" THEN ICLOSE T;               
                                                                
                                                                
: .C ( -- )                                                     
\ Display context stack contents.                               
  CR CDEPTH IF CXSP @ 3 + END-CX                                
               DO I 1.5@ .DRJ -3 +LOOP                          
            ELSE ." MT STK"                                     
            THEN CR ;                                           
                                                                
EXIT                                                            
: .C+ ( -- )                                                    
\ Display top 3 items on context stack w/ descriptors.          
 CR CI  .INM   \ current instance                               
\ CR CI' .INM   \ current container                             
\ CR CJ  .INM ; \ container's container                         
EXIT                                                            
                                                                
HEAD: INDENT.INM ( -- t )                                       
\ Display indented name of ci.                                  
T: CR CI CDEPTH 2* SPACES .INM ?TERMINAL                        
   IF QUIT THEN T;                                              
                                                                
                                                                
: .TREE ( { n -- n } )                                          
\ Display offspring tree for CI.                                
  ' INDENT.INM  'MAP  DUP@>V!                                   
  ' ?FIRST     '?EXIT DUP@>V!                                   
  ' INEXT   'TRAVERS  DUP@>V!                                   
  MAP>LEAF                                                      
\ 'TRAVERS  V>SWAP!                                             
\ '?EXIT    V>SWAP!                                             
\ 'MAP      V>SWAP! ;                                           
                                                                
\ OVERLAY SYSTEM - START                                        
HEAD: OVA@ T: OVA @ T;                                          
                                                                
: OV-CANCEL ( -- )                                              
\ Cancel overlay.                                               
  OV# @                                                         
  IF OVA@ DUP 4 + @ = \ valid overlay in memory?                
     IF OVA@ 8 + @ 4 + 8 0 FILL THEN \ clear link heads         
  THEN                                                          
  OV# <OFF>  ' FORTH DUP CURRENT <!> CONTEXT <!> ;              
                                                                
                                                                
                                                                
HEAD: VSA>BUFADR ( vsa -- addr)                                 
\ Compute buffer address of vsa.                                
T: DUP MOUNT-VSA VSA>VA VA>BUF T;                               
                                                                
HEAD: ?ROOMERROR ( ova -- )                                     
\ Display error message if ova collides with dictionary.        
T: HERE U< IF ." OV TOO BIG" UNRAVEL THEN T;                    
                                                                
                                                                
HEAD: OV-VERIFY ( vsa -- )                                      
\ Overlay consistency check.                                    
T: DUP VSA>BUFADR     ( vsa adr -- \ get parm record )          
  2DUP @ -            ( vsa adr t --)                           
  IF ." INV OV BLK" UNRAVEL THEN                                
  4 + @ ?ROOMERROR DROP T;                                      
\ ' nop c: 'ldov                                                
                                                                
HEAD: LOAD-OVERLAY ( vsa -- )                                   
\ Load overlay from disk to memory.                             
T: ?DUP                                                         
  IF      ( vsa -- \ only if vsa is not null)                   
    DUP OV# @ =  \ all ready loaded?                            
    IF DROP                                                     
    ELSE DUP                                                    
       OV-VERIFY      ( vsa -- \ abort if invalid overlay)      
       OV-CANCEL      \ cancel previous overlay                 
       VSA>BUFADR >R                                            
       I 4 + @ DUP OVA <!>  ADDR>SEG   I @ DUP OV# <!>          
       R> 2+ @  MEM<DSK                    \ load to mem        
       OVA@ 10 +  OVA@ 8 + @ 4 + 8 CMOVE \ restore links        
       OVA@ 8 + @ 2- DUP                                        
       CONTEXT <!> CURRENT <!> \ get voc-link                   
    THEN                                                        
  THEN ( 'ldov execute ) T;                                     
                                                                
                                                                
: SAVE-OVERLAY ( -- )                                           
\ Save overlay memory image on disk.                            
  OV# @        \ if there is an overlay in memory               
  IF OVA@ >R                                                    
     I 8 + @ 4 +  I 10 + 8 CMOVE \ preserve link heads          
     I ADDR>SEG  I @                                            
     R> 2+ @  MEM>DSK            \ save image                   
  THEN ;                                                        
                                                                
                                                                
: OVERLAY ( directory# -- )                                     
\ Create an overlay caller.                                     
  CREATE  FILE-START @                                          
          DUP , OV-VERIFY  \ varify that overlay is on disk     
  DOES>  @ LOAD-OVERLAY ;                                       
                                                                
                                                                
HEAD: DP-SWITCH ( -- )                                          
\ Toggle between main & overlay.                                
T:  DP @   OVA@ 6 + @   DP <!>  OVA@ 6 + <!> T;                 
                                                                
                                                                
: OPEN-OVERLAY ( directory# -- )                                
\ Free space for creation of an overlay image with size         
\ and start specified in the directory.                         
  DUP FILE-START @ SWAP FILE-#REC @ ( [diskvsa][#vsa] --)       
  OVER OV# <!>                                                  
  DUP  16* NEGATE  EM +      \ overlay address                  
  DUP ?ROOMERROR             \ enough room?                     
  DUP OVA <!>                \ is overlay mem vsa               
  HERE OVER 6 + <!> DP <!>   \ save DP, new DP=OVA              
  SWAP , ,                   \ diskvsa, #vsa                    
  OVA@ ,                     \ save load address vsa            
  2 ALLOT                    \ OV-DP                            
  VOC-LINK @ ,               \ save VOC-LINK                    
  8 ALLOT                    \ space for links                  
  2 ALLOT ;                  \ space for computed vsa count     
                                                                
                                                                
HEAD: .CVSAS ( -- )                                             
\ Save and display computed length of OV's.                     
T: CR CONTEXT @ NFA ID.                                         
   OVA@ HERE OVER - 16/ 1+ DUP .                                
   ." SEGS USED" SWAP 18 + <!> T;                               
                                                                
                                                                
: CLOSE-OVERLAY ( -- )                                          
\ Close overlay area and send to disk.                          
  .CVSAS                                                        
  DP-SWITCH         \ DP back to main dictionary                
  SAVE-OVERLAY SAVE-BUFFERS                                     
  OV-CANCEL ;                                                   
                                                                
: MODULE ( pfa-module-caller -- )                               
\ Call a module.                                                
  OV# @ >V        \ preserve current overlay on vector stack    
  SAVE-OVERLAY    \ save current overlay to preserve variables  
  EXECUTE         \ call module                                 
  V> LOAD-OVERLAY ; \ restore previous overlay                  
                                                                
\                                                               
\ OVERLAY SYSTEM - DOCUMENTATION                                
\                                                               
\                                                               
\                                                               
\    PFA of an overlay caller:                                  
\      VSA                                                      
\      +0                                                       
\                                                               
\    Parameter-block of the overlay:                            
\   VSA  VSAS  OVA  OV-DP  VOC.SAVE  LINK1 LINK2 LINK3 LINK4    
\   +0    +2   +4     +6     +8       +10   +12   +14   +16     
\   CVSAS                                                       
\    +18                                                        
                                                                
( GRAPHICS - 1ST BLOCK  !COLOR                        12-31-84) 
                                                                
: !COLOR ( c -- ) DUP COLOR ! DCOLOR ! ;                        
: @COLOR ( -- c ) COLOR @ ;                                     
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
SUB: TREJECT/TACCEPT                                            
\ Compute outcodes & reject/accept flags.                       
  0 DS SSG   0 ES LSG  \ make es same as ds                     
  R PUSH               \ preserve r                             
  W PUSH               \ preserve w                             
  I PUSH               \ preserve i                             
  15 #B U MOV          \ set initial TRJCT value                
  U HI U HI XOR B      \ set initial TACCPT value               
  VIN I MOV            \ set source pointer to y,x array        
  OIN W MOV            \ set dest pointer to outcode array      
  IBELOW R MOV         \ move window bottom to register         
  #IN 1 MOV            \ set vertex count                       
  BEGIN                                                         
    2 2 XOR            \ init outcode accumulator               
    LODS               \ get y                                  
    R       0 CMP  0< IF 04 # 2 OR THEN  \ below?               
    IABOVE  0 CMP  0> IF 08 # 2 OR THEN  \ above?               
    LODS               \ get x                                  
    ILEFT   0 CMP  0< IF 01 # 2 OR THEN  \ to lft of window?    
    IRIGHT  0 CMP  0> IF 02 # 2 OR THEN  \ to right?            
    2 0 MOV STOS B     \ save outcode                           
    2 U AND B          \ accum. TRJCT                           
    2 U HI OR B        \ accum. TACCPT                          
  LOOP                                                          
  0 0 XOR              \                                        
  U 0 MOV B            \ extend byte to word                    
  0 TRJCT MOV          \ save TRJCT flag                        
  U HI 0 MOV B         \ save TACCPT flag                       
  0 TACCPT MOV I POP   \ restore I                              
  W POP                \ restore W                              
  R POP                \ restore R                              
  RET                                                           
                                                                
ASSEMBLER                                                       
SUB: INT/O                                                      
( SY SX PY PX X-INTER FLIP --> OC=AX, IX=CX, IY=DX)             
  U PUSH               \ preserve registers                     
  R PUSH               \                                        
  I PUSH               \                                        
  W PUSH               \                                        
  PX 1 MOV             \ move endpoints to registers            
  PY I MOV             \                                        
  SX R MOV             \                                        
  SY W MOV             \                                        
  1 # FLIP CMP 0=      \ adjust if y boundary crossed           
  IF 1 I XCHG  R W XCHG THEN                                    
  X-INTER 0 MOV        \ x intercept - clp bound                
  1  0 SUB             \ xint-px                                
  W  U MOV             \ sy                                     
  I  U SUB             \ sy-py                                  
  U IMUL               \ (xint-px)*(sy-py)                      
  R  U MOV             \ sx                                     
  1  U SUB             \ sx-px                                  
  U  IDIV              \ (xint-px)*(sy-py)/(sx-px)              
  I  0 ADD             \ yint                                   
  0  2 MOV             \ IY - intercept y                       
  X-INTER 1 MOV        \ IX - intercept x                       
  1 # FLIP CMP 0= IF 1 2 XCHG THEN                              
  0 0 SUB                                                       
  ILEFT   1 CMP  0< IF 01 # 0 OR THEN  \ left?                  
  IRIGHT  1 CMP  0> IF 02 # 0 OR THEN  \ right?                 
  IBELOW  2 CMP  0< IF 04 # 0 OR THEN  \ below?                 
  IABOVE  2 CMP  0> IF 08 # 0 OR THEN  \ above?                 
  W POP                \ restore registers                      
  I POP                \                                        
  R POP                \                                        
  U POP                \                                        
  RET                                                           
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ GRAPHICS - CLIPPER - 3 of 5                                   
SUB: CLIP 0 # #OUT MOV  IVPTR I XCHG  OVPTR W XCHG              
  ICPTR U XCHG  OCPTR R XCHG  VIN I MOV  VOUT W MOV  OIN U MOV  
  OOUT R MOV #IN 1 MOV  1 # ?OPEN CMP  0=                       
  if  i ) 0 mov  0 sy mov  2 i) 0 mov  0 sx mov                 
      u ) 0 mov b  0 so mov b  compare-code 0 and b  0=         
      if movs movs  so 0 mov b  0 r ) mov b  r inc  #out inc    
      else 4 # i add                                            
      then                                                      
      1 dec  u inc                                              
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ GRAPHICS - CLIPPER - 4 of 5                                   
  ELSE                                                          
 1 DEC  1 U ADD  U ) 0 MOV B  0 SO MOV B  1 U SUB 1 0 MOV 0 SHL 
  0 SHL 0 I ADD  I ) 2 MOV 2 SY MOV 2 I) 2 MOV 2 SX MOV 0 I SUB 
  1 INC  THEN  here zzz !                                       
                     I ) 0 MOV  0 PY MOV  2 I) 0 MOV  0 PX MOV  
  U ) 0 MOV B 0 PO MOV B U INC COMPARE-CODE 0 MOV PO 0 AND B    
  SO 0 HI AND B 0 0 HI CMP B 0= NOT IF 1 PUSH 0 PUSH 1 1 XOR    
  X-INTER 0 MOV  0 # FLIP CMP  0= IF PX 0 CMP  0= NOT IF 1 INC  
  THEN  SX 0 CMP  0= NOT IF 1 # 1 AND ELSE 1 1 XOR THEN ELSE    
  PY 0 CMP 0= NOT IF 1 INC THEN SY 0 CMP 0= NOT IF 1 # 1 AND    
  ELSE 1 1 XOR THEN THEN  1 # ?open cmp 0= if 1 inc then        
                         1 1 OR 0= NOT IF INT/O CALL            
  2 W ) MOV 2 # W ADD 1 W ) MOV 2 # W ADD 0 R ) MOV R INC #OUT  
  INC THEN                                                      
                                                                
( GRAPHICS - CLIPPER - 4 of 5                          2-18-85) 
ASSEMBLER                        HEX                            
  0 POP 1 POP THEN 0 0 OR B 0= IF MOVS MOVS PO 2 MOV B          
  2 R ) MOV B R INC #OUT INC ELSE 4 # I ADD THEN PY 0 MOV       
  0 SY MOV  PX 0 MOV  0 SX MOV  PO 0 MOV B 0 SO MOV B           
  1 DEC 74 C, 03 C, E9 C, zzz @ here 2+ - ,                     
  VIN 0 MOV  VOUT 1 MOV 0 VOUT MOV 1 VIN MOV OIN 0 MOV          
  OOUT 1 MOV  0 OOUT MOV 1 OIN MOV #OUT 0 MOV 0 #IN MOV         
  IVPTR I XCHG OVPTR W XCHG ICPTR U XCHG OCPTR R XCHG RET       
DECIMAL                                                         
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( GRAPHICS - CLIPPER - 5 of 5                          2-18-85) 
CODE CLIPPER ( -- 2D window clipper)                            
  W PUSH TREJECT/TACCEPT CALL   TRJCT 0 MOV   0 0 OR 0= NOT     
  IF 0 # #IN MOV                                                
  ELSE  TACCPT 0 MOV  0 0 OR 0= NOT                             
    IF   CLIP-TABLE # W MOV   4 # 1 MOV                         
      BEGIN  W ) 2 MOV  2 0 TEST B 0= NOT                       
        IF 2 COMPARE-CODE MOV  2 # W ADD  2 2 xor  w ) 2 MOV B  
           2 FLIP MOV   W INC  W ) 2 MOV 2 X-INTER MOV          
           2 # W ADD 0 PUSH 1 PUSH   CLIP CALL  1 POP           
           0 0 OR 0= IF 1 # 1 MOV THEN 0 POP                    
        ELSE 5 # W ADD                                          
        THEN                                                    
      LOOP                                                      
    THEN THEN W POP NEXT                                        
                                                                
( GRAPHICS - SCANPOLY - 1 OF 3                         8-23-85) 
HEX                                                             
SUB: SCANCON PX PUSH  SY 0 MOV  PY 1 MOV  1 PUSH  0 1 CMP       
  0< IF 1 SY MOV  0 PY MOV  SX 1 MOV  PX 0 MOV  0 SX MOV        
  1 PX MOV THEN        B3 C, C3 C, PX 0 MOV                     
  SX 0 SUB  7D C, 04 C, B3 C, CB C, 0 NEG  0 1 MOV  B7 C, C7 C, 
  PY 0 MOV  SY 0 SUB  0 2 MOV                                   
  1 2 CMP  7D C, 04 C,  2 1 XCHG  U HI U XCHG B                 
  SCANCON # W MOV  87 # W ADD                                   
  U HI W ) MOV B  3 # W ADD  1 W ) MOV  1 SHR  4 # W ADD        
  1 W ) MOV  6 # W ADD  2 W ) MOV  3 # W ADD  U W ) MOV B       
  SX U MOV B  SY U HI MOV B  1 1 XOR  0 0 XOR  U HI 0 MOV B     
  0 SHL  SCAN+ 0 ADD  0 W MOV  U W ) MOV B  FE C, C3 C,         
  1111 # 1 ADD  1111 # 1 CMP  0> IF 1111 # 1 SUB  FE C, C7 C,   
  THEN  2 DEC  7D C, DD C, PY POP  PX POP RET                   
DECIMAL                                                         
( GRAPHICS - SCANPOLY - 2 OF 3                        10-12-84) 
HEX ASSEMBLER                                                   
CODE SCANPOLY  W PUSH  1 1 XOR                                  
  1 #HORIZ MOV     1 ELEMENT MOV  VIN W MOV  #IN 0 MOV          
  0 DEC  0 SHL  0 SHL  0 W ADD  W ) 1 MOV  1 SY MOV             
  2 # W ADD  W ) 1 MOV  1 SX MOV  VIN W MOV  W ) 1 MOV          
  1 YMIN MOV  1 YMAX MOV  #IN 1 MOV  W ) 0 MOV                  
  0 PY MOV  2 # W ADD  W ) U MOV  U PX MOV  2 # W ADD           
  SY 2 MOV  2 0 CMP  0= IF  #HORIZ INC  SX U CMP  0< IF         
  SX PUSH U PUSH ELSE U PUSH SX PUSH THEN 0 PUSH                
  ELSE  YMIN 2 MOV  0 2 CMP                                     
  0> IF  0 YMIN MOV  ELSE  YMAX 2 MOV  0 2 CMP 0< IF            
  0 YMAX MOV  THEN  THEN  2 2 XOR SY U MOV  0 U CMP  0> IF      
  2 INC THEN  2 ELEMENT MOV  SCAN 2 ADD                         
  2 SCAN+ MOV  1 PUSH  W PUSH  SCANCON CALL W POP 1 POP         
  THEN  PY 0 MOV  0 SY MOV  PX 0 MOV  0 SX MOV  1 DEC           
( GRAPHICS - SCANPOLY - 3 OF 3                        10-12-84) 
HEX ASSEMBLER                                                   
  74 C, 03 C, E9 C, FF7F ,                                      
  1 #HORIZ CMP  0>   ( any horizontals?)                        
  IF 900 # 0 MOV  0 SY MOV  #HORIZ 1 MOV                        
    BEGIN   2 POP  2 W MOV  W SHL  SCAN W ADD  SY 2 CMP         
      0= IF 0 POP  W ) 0 HI MOV B  0 HI 0 CMP B                 
            0< IF 0 W ) MOV B THEN                              
            W INC  0 POP  W ) 0 HI MOV B  0 HI 0 CMP B          
            0> IF 0 W ) MOV B THEN                              
         ELSE  2 SY MOV  0 POP  0 W ) MOV B  0 POP  W INC       
            0 W ) MOV B                                         
         THEN                                                   
    LOOP                                                        
  THEN                                                          
  W POP  NEXT  DECIMAL                                          
( GRAPHICS - SETCLIPWINDOW, SCLIPSET, VCLIPSET         1-08-85) 
                                                                
: SETCLIPWINDOW                                                 
( top right bottom left -- \ set clipping windw)                
  DUP ILEFT   ! CLIP-TABLE 18 + !                               
  DUP IBELOW  ! CLIP-TABLE 13 + !                               
  DUP IRIGHT  ! CLIP-TABLE  8 + !                               
  DUP IABOVE  ! CLIP-TABLE  3 + ! ;                             
                                                                
: VCLIPSET ( -- \ set clipping window to main view screen)      
  119 71 0 0 SETCLIPWINDOW ;                                    
: DCLIPSET ( -- \ set clipping window for entire display)       
  199 159 0 0 SETCLIPWINDOW ;                                   
DCLIPSET                                                        
                                                                
                                                                
\ GRAPHICS - LADD LADDH ?HERCULES                               
HEX                                                             
ASSEMBLER ( compute display address for y x - IBM GRAPHIC)      
CODE: LADD ( y x -- a)                                          
\ IBM graphic card lores pixel offset computation.              
  0 POP  0 SHR  1 POP                                           
  C7 # U MOV  1 U SUB  1 # U TEST                               
  0= NOT IF 2000 # 0 ADD  -2 # U AND  THEN  U 0 XCHG            
  28 # 1 MOV 1 MUL   0 U ADD  U 0 MOV 0 PUSH NEXT               
HEAD: LADDH ( y x -- a )                                        
\ Hercules graphic card lores pixel offset computation.         
T: 28 + SWAP 111 - ABS SWAP \ center w/in Herc screen           
   8 / SWAP DUP 4 MOD 2000 * SWAP 4 / 05A * + + T; DECIMAL      
: ?HERCULES ( -- t )                                            
\ Is Hercules graphics card mode selected?                      
  MONITOR @ 4 = ;                                               
\ GRAPHICS - BLD-DIS BLD-MV                                     
HEAD: YTABLE.ADDRESS ( n -- a ) T: 2* YTABLE + T;               
: BLD-DIS ( -- )                                                
\ Build full display y scanline offset table.                   
  ?HERCULES IF ' LADDH ELSE ' LADD THEN                         
  200 0 DO I 0 3 PICK EXECUTE I YTABLE.ADDRESS !                
        LOOP DROP ;                                             
TRANSIENT                                                       
: BLD-MV ( -- )                                                 
\ Build mainview y scanline offset table.                       
   120 0 DO 0 I 1 AND IF 2160 + THEN                            
            I 2/ 36 * + VYTABLE  I 2* + !                       
         LOOP ;                                                 
RESIDENT                                                        
BLD-DIS BLD-MV                                                  
                                                                
\ GRAPHICS - >MAINVIEW >DISPLAY >HIDDEN                         
HEAD: HID-DIS                                                   
T: 0 200 0 DO DUP I YTABLE.ADDRESS ! 80 + LOOP DROP T;          
HEAD: ?HID-DIS T: 0 YTABLE.ADDRESS @ NOT T;                     
: >MAINVIEW ( -- \ direct graphics to the mainview buffer)      
   VYTABLE YTABL !  HBUF-SEG @ BUF-SEG !  4320 BUF-CNT ! ;      
                                                                
: >DISPLAY  ( -- \ direct graphics to the display)              
  ?HID-DIS IF BLD-DIS THEN                                      
  YTABLE YTABL ! DBUF-SEG @ BUF-SEG ! DBUF-SIZE BUF-CNT ! ;     
                                                                
: >HIDDEN  ( -- \ direct graphics to the hidden display buffer) 
  ?HID-DIS NOT IF HID-DIS THEN YTABLE YTABL !                   
  HBUF-SEG @ BUF-SEG ! DBUF-SIZE BUF-CNT ! ;                    
                                                                
                                                                
\ GRAPHICS - SET6845                                            
HEX ASSEMBLER                                                   
CREATE SET6845                                                  
\ Set the values for registers R0-RB in 6845 graphics chip      
\ using the table pointed to by I and the chip pointed to by    
\ DX.                                                           
  0E # 1 MOV                                                    
  0 HI 0 HI XOR B                                               
  BEGIN                                                         
    0 HI 0 MOV B  (2) OUT  2 INC  LODS B                        
    (2) OUT  1 #B 0 HI ADD  2 DEC                               
  LOOP                                                          
  RET                                                           
DECIMAL                                                         
                                                                
                                                                
\ GRAPHICS - GIBM GHERC THERC                                   
HEX                                                             
CREATE GIBM  \ ibm graphics mode 6845 parms                     
     38 C, 28 C, 2D C, 0A C, 7F C, 06 C,                        
     64 C, 70 C, 02 C, 01 C, 08 C, 08 C, 00 C, 00 C,            
CREATE GHERC \ hercules graphics mode 6845 parms                
     35 C, 2D C, 2E C, 07 C, 5B C, 02 C,                        
     57 C, 57 C, 02 C, 03 C, 00 C, 00 C, 00 C, 00 C,            
CREATE THERC \ hercules text mode 6845 parms                    
     61 C, 50 C, 52 C, 0F C, 19 C, 06 C,                        
     19 C, 19 C, 02 C, 0D C, 0B C, 0C C, 00 C, 00 C,            
DECIMAL                                                         
                                                                
                                                                
                                                                
                                                                
\ GRAPHICS - >HGRAPH >HTEXT                                     
HEX ASSEMBLER                                                   
CREATE >HGRAPH                                                  
\ Set hercules card graphics mode and make page 0 visible page. 
  3B8 # 2 MOV  2 #B 0 MOV  (2) OUT \ turn off display           
  1 #B 0 MOV  3BF # 2 MOV  (2) OUT \ enable graphic & 1st page  
  3B4 # 2 MOV  GHERC # I MOV  SET6845 CALL                      
  3B8 # 2 MOV  0A #B 0 MOV (2) OUT \ graphic mode and turn on.  
  RET                              \ page 0. (half config)      
CREATE >HTEXT                                                   
\ Set hercules card text mode and make page 0 visible page.     
  3B8 # 2 MOV 20 #B 0 MOV  (2) OUT \ turn off display           
  0 #B 0 MOV  3BF # 2 MOV  (2) OUT \ disable graphic & 2nd page 
  3B4 # 2 MOV  THERC # I MOV  SET6845 CALL                      
  3B8 # 2 MOV  28 #B 0 MOV (2) OUT \ text mode and turn on.     
  RET DECIMAL                      \ page 0. (half config)      
\ GRAPHICS - >LORES                                             
hex v= ?tandrgb ?tandrgb off   \ tandy rgb mode flag            
CODE >LORES ( -- \ initialize for low res based on monitor)     
  I PUSH W PUSH  MONITOR W MOV  4 # W CMP 0=                    
  IF >HGRAPH CALL                      \ hercules mode          
  ELSE                                                          
     3D4 # 2 MOV  GIBM # I MOV  SET6845 CALL                    
     1 # ?tandrgb cmp 0=               \ rgb tandy              
     if 3 #b 0 mov  3da # 2 mov  (2) out                        
        10 #b 0 mov 3de # 2 mov  (2) out \ tandy 16 color mode  
        1 #b 0 mov  3da # 2 mov  (2) out                        
        0f #b 0 mov 3de # 2 mov  (2) out \ pallete mask reg     
        0a27 # u mov                                            
     else 1a27 # u mov    \ default-composite artifact mode     
     then  3d8 # 2 mov    \ 6845 mode register address          
     1 # W CMP 0= IF 1E27 # U MOV THEN \ b/w                    
\ GRAPHICS - >ALPHA  BYE                                        
     2 # W CMP 0= IF 2A20 # U MOV THEN \ rgb color - non-tandy  
     U HI 0 MOV B (2) OUT   2 INC   U 0 MOV B  (2) OUT          
  THEN                                                          
  W POP I POP NEXT decimal                                      
                                                                
HEX                                                             
CODE >ALPHA ( -- \ initialize for bw alpha mode 80x25)          
  I PUSH W PUSH  MONITOR W MOV  4 # W CMP 0=                    
  IF >HTEXT CALL                  \ hercules mode               
  ELSE 2 # 0 MOV CD C, 10 C,      \ call bios text mode         
  THEN W POP I POP NEXT                                         
decimal                                                         
                                                                
                                                                
                                                                
\ GRAPHICS - V>D                                                
                                                                
HEX ASSEMBLER                                                   
CREATE V>D ( -- )                                               
\ Copy interlaced 1/2 of main view screen to display.           
  3C # 1 MOV                                                    
  BEGIN  1 R MOV                                                
     U W MOV  W ) W MOV  W INC W INC  \ dest offset             
     0 DS LSG                                                   
     12 # 1 MOV  REP MOVS                                       
     4 # U ADD               \ next odd/even scan line          
     2 DS LSG  R 1 MOV                                          
  LOOP RET                                                      
DECIMAL                                                         
                                                                
                                                                
\ GRAPHICS - V>DISPLAY                                          
HEX                                                             
CODE V>DISPLAY ( -- )                                           
\ Copy main view screen to display at 4,191.                    
  W PUSH R PUSH I PUSH  2 DS SSG   >DISPLAY YTABL @             
  48 2* + # U MOV                                               
  DBUF-SEG 0 MOV  0 ES LSG  HBUF-SEG 0 MOV                      
  I I XOR                                                       
  V>D CALL 0EE # U SUB                                          
  V>D CALL                                                      
  2 ES LSG                                                      
  I POP  R POP  W POP                                           
  NEXT                                                          
DECIMAL                                                         
                                                                
                                                                
\ GRAPHICS - |DISPLAY SCANLINE                                  
                                                                
HEAD: SCANLINE ( n -- seg offset )                              
T: DBUF-SEG @ SWAP YTABLE.ADDRESS @ T;                          
                                                                
: |DISPLAY ( seg 0/1 -- )                                       
\ Move entire display to/from seg. 0->seg.                      
  >R                                                            
  200 0 DO I SCANLINE                                           
           3 PICK  I 80 *      ( d-scn d-seg -- )               
           J IF 2SWAP THEN                                      
           80 LCMOVE                                            
        LOOP                                                    
  R> 2DROP ;                                                    
                                                                
                                                                
\ GRAPHICS - SAVE-SCR SCR-RESTORE                               
                                                                
: SAVE-SCR    ( -- ) HBUF-SEG @ 0 |DISPLAY ;                    
                                                                
: SCR-RESTORE ( -- ) HBUF-SEG @ 1 |DISPLAY ;                    
                                                                
                                                                
( GRAPHICS - BFILL,          DARK  bye                12-05-85) 
                                                                
CODE BFILL ( -- \  fill current buffer with current color)      
  W PUSH  COLOR 0 MOV  0 0 HI MOV B  ES PUSHS                   
  BUF-SEG 1 MOV  1 ES LSG  BUF-CNT 1 MOV  1 SHR                 
  W W XOR  REP STOS ES POPS W POP NEXT                          
                                                                
                                                                
: DARK ( -- \ fill current buffer with black)                   
  @COLOR BLACK COLOR ! BFILL COLOR ! ;                          
                                                                
: BYE >ALPHA BEEPOFF ?hercules if >display dark page then       
                     BYE ;                                      
                                                                
                                                                
\ GRAPHICS - V>AUX  not used                                    
exit                                                            
HEX                                                             
SUB: (V>A)                                                      
  24 # 1 MOV  7A # W MOV  BEGIN  1 PUSH  12 # 1 MOV  REP MOVS   
  2C # W ADD  1 POP  LOOP RET                                   
CODE V>AUX ( copy from main view buffer to aux window)          
  W PUSH I PUSH  ES PUSHS  DS PUSHS                             
  DBUF-SEG 1 MOV  1 ES LSG              ( destination)          
  HBUF-SEG 1 MOV  1 DS LSG  360 # I MOV ( source)               
  (V>A) CALL  1 ES SSG  200 # 1 ADD  1 ES LSG  360 # I ADD      
  (V>A) CALL  DS POPS  ES POPS  I POP  W POP NEXT               
DECIMAL                                                         
                                                                
                                                                
                                                                
( GRAPHICS -         DISPLAY-WAIT                      3-05-85) 
                                                                
HEX                                                             
CODE DISPLAY-WAIT  ( wait for vblank)                           
  3DA # 2 MOV  4 # 0 MOV  MONITOR 0 SUB                         
  0= IF 3BA # 2 MOV THEN                                        
  BEGIN  (2) IN  1 # 0 AND 0= UNTIL                             
  BEGIN  (2) IN  1 # 0 AND 0= NOT UNTIL NEXT                    
DECIMAL                                                         
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( GRAPHICS - BLT support                               12-05-85)
                                                                
HEX                                                             
SUB: {BLTBITS} ( -- \ load blt image bits from any segment)     
  ( and advance image word pointer)                             
  W PUSH  ES PUSHS  BLTSEG PUSH  ES POPS  BLT> W MOV            
  ES SEG W ) R MOV  W INC  W INC  W BLT> MOV  10 #B 1 MOV       
  ES POPS W POP RET                                             
                                                                
SUB: {ADVBITS} ( -- \ advance bit image bit pointer by count)   
  ( in register 0)                                              
  FE C, C9 C, 0= IF {BLTBITS} CALL THEN R SHL                   
  0 DEC  75 C, F4 C, RET                                        
                                                                
                                                                
                                                                
( GRAPHICS - BLT support                               8-23-85) 
HEX                                                             
SUB: {BLTCOL} ( -- \ do 1 or 2 pixels in the current row)       
  FE C, C7 C,                    \ u hi inc - inc loop counter  
  2 HI 2 HI XOR B                \ clear pixel mask             
  1 #B U HI CMP                  \ 1st column ?                 
  75 C, 0A C,                    \ if not, go to [B]            
  1 # XBLT TEST                  \ is xblt odd?                 
  74 C, 02 C,                    \ if xblt is even goto [B]     
  EB C, 1A C,                    \ else goto [C]                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( GRAPHICS - BLT support                               2-13-85) 
HEX ASSEMBLER                                                   
  \ [B]                                                         
  FE C, C9 C,                    \ 1 DEC B, bits in mem         
  0= IF {BLTBITS} CALL THEN      \ if out of bits, get more     
  R SHL                          \ shift bit into carry         
  CS IF                          \ if bit set ...               
        IRIGHT 0 CMP 77 C, 08 C, \ if right of window -->[N]    
        ILEFT 0 CMP 72 C, 02 C,  \ if left of window --> [N]    
        F0 #B 2 HI MOV THEN      \ else , mask hi nybble.       
  \ [N]                                                         
  0 INC                          \ inc current x location       
  \ [C]                                                         
  U HI U CMP B 75 C, 0A C,       \ if not last column goto [D]  
  1 # LPX TEST 74 C, 02 C,       \ if lpx not set goto [D]      
  EB C, 1B C,                    \ else goto [E]                
( GRAPHICS - BLT support                               2-13-85) 
HEX ASSEMBLER                                                   
  \ [D]                                                         
  FE C, C9 C,                    \ 1 DEC B, bits in mem         
  0= IF {BLTBITS} CALL THEN      \ if out of bits, get more     
  R SHL                          \ shift bit into carry         
  CS IF                          \ if bit set ...               
        IRIGHT 0 CMP 77 C, 09 C, \ if right of window -->[O]    
        ILEFT 0 CMP 72 C, 03 C,  \ if left of window --> [O]    
        0F #B 2 HI OR  THEN      \ else  , mask lo nybble       
  \ [O]                                                         
  0 INC                          \ inc current x location       
  \ [E]                                                         
  2 HI 2 HI OR B  74 C, 20 C,    \ is no change-->[P]           
  2 HI 2 MOV B                   \ save mask                    
  COLOR 2 HI AND B               \ add color info to mask       
( GRAPHICS - BLT support                               2-13-85) 
HEX ASSEMBLER                                                   
  ES SEG W ) 0 HI MOV B          \ get a pixel pair from buffer 
  1 # XORMODE TEST 74 C, 04 C,   \ if not xormode goto [F]      
  2 HI 0 HI XOR B                \ xor mask w/pixel pair        
  EB C, 06 C,                    \ goto [G]                     
  \ [F]                                                         
  2 COM B  2 0 HI AND B          \ punch holes for new pixels   
  2 HI 0 HI OR B                 \ insert new pixels            
  \ [G]                                                         
  ES SEG 0 HI W ) MOV B          \ write pixel pair to buffer   
  0 HI 0 HI XOR B                \ clear temp reg               
  \ [P]                                                         
  W INC                          \ bump pixel pointer           
  RET                            \                              
                                                                
( GRAPHICS - BLT                                       2-11-85) 
HEX ASSEMBLER                                                   
CODE {BLT} ( -- \ plot a bit pattern given parameters)          
  W PUSH I PUSH R PUSH ES PUSHS  \ preserve forth registers     
  BUF-SEG PUSH  ES POPS          \ set es to display buffer     
  ABLT 1 MOV  1 BLT> MOV         \ init blt image pointer       
  WBLT 0 MOV 0 1 MOV XBLT 0 XOR  \ compute last pixel flag      
  0 LPX MOV                      \ save last pixel flag         
  1 0 MOV 0 INC 0 SHR            \ compute column loop limit    
  1 # XBLT TEST 0= NOT           \ if xblt odd and ...          
  IF 1 # 1 TEST 0=               \ ...wblt even...              
     IF 0 INC THEN THEN          \ ...adjust column loop limit. 
  0 U MOV B                      \ save column loop limit       
  1 # 1 MOV                      \ bits=1 to trigger {bltbits}  
                                                                
                                                                
( GRAPHICS - BLT                                       2-11-85) 
ASSEMBLER HEX                                                   
  \ [I] - BEGIN ROW (OUTER) LOOP                                
  0 0 XOR                        \ clear workspace register     
  1 HI 0 MOV B                   \ get scanline counter         
  YBLT I MOV                     \ get initial scanline         
  0 I SUB                        \ compute current scan line    
  IBELOW I CMP 72 C, 37 C,       \ if line below window-->[J]   
  IABOVE I CMP 76 C, 09 C,       \ if visible row --> [L]       
  WBLT 0 MOV  {ADVBITS} CALL     \ advance image ptr by 1 row   
  EB C, 1D C,                    \ goto [K] -- next row         
  \ [L]                                                         
  I SHL YTABL I ADD              \                              
  XBLT 0 MOV  0 SAR I ) 0 ADD    \ computer buffer addr         
                                                                
                                                                
( GRAPHICS - BLT                                       2-11-85) 
ASSEMBLER HEX                                                   
  0 W MOV                        \ preserve buffer addr         
  0 #B U HI MOV                  \ initialize column loop count 
  XBLT 0 MOV                     \ initialize blt x pointer     
  \ [H] - BEGIN COLUMN (INNER) LOOP                             
  {BLTCOL} CALL                  \ do 1 or 2 pixels             
  U HI U CMP B 75 C, F9 C,       \ if not last column goto [H]  
  \ [K] - END OF COLUMN LOOP                                    
  FE C, C5 C,                    \ inc row counter              
  1 HI 0 MOV B  CBW              \ get row counter word         
  0 LBLT CMP   75 C, B9 C,       \ if not last row goto [I]     
  \ [J]                                                         
  ES POPS R POP I POP W POP NEXT \ restore forth pointers       
DECIMAL                                                         
                                                                
( GRAPHICS -         ?EXTENTX                          2-11-85) 
ASSEMBLER                                                       
CODE: ?EXTENTX ( xll yll xur yur -- \ text loc. of extent rel.) 
 ( to clipping window - result is in trjct & taccpt)            
 ( IMPORTANT: USES VIN & OIN AS TEMP SPACE )                    
 VIN U MOV  4 # 1 MOV  BEGIN U ) POP 2 # U ADD LOOP             
 2 # U MOV  U #IN MOV  W PUSH  TREJECT/TACCEPT CALL W POP NEXT  
CODE: BEXTENT ( -- xll yll xur yur \ push blt extent)           
  XBLT PUSH  YBLT 0 MOV  LBLT 0 SUB 0 INC 0 PUSH                
  XBLT 0 MOV  WBLT 0 ADD  0 DEC 0 PUSH  YBLT PUSH NEXT          
                                                                
: BLT ( -- \ plot a clipped blt with extent clipping)           
  V1 VIN ! V2 OIN !                                             
  BEXTENT  ?EXTENTX TRJCT @ 0=                                  
  IF {BLT} THEN ;                                               
                                                                
( GRAPHICS - >0FONT, >1FONT                           10-12-84) 
HEAD: {1FONT} ( n --, EMIT routine for 3x5/5x5 graphics font )  
T:  @DS BLTSEG !                                                
  5 lBLT ! DUP 91 < IF 32 - 2* 3X5CHAR + aBLT ! 3 wBLT ! 4      
                    ELSE 91 - 2* 2*  5X5CHAR + aBLT ! 5 wBLT ! 6
                    THEN BLT xBLT +! T;                         
HEAD: {GTYPE} ( addr count -- \ graphics mode TYPE routine )    
T: 2DUP >UPPERCASE 0 DO DUP C@ EMIT 1+ LOOP DROP T;             
                                                                
: >1FONT ( select 5x graphics font)                             
  ' {1FONT} ' EMIT   EXECUTES                                   
  ' {GTYPE} ' TYPE   EXECUTES ;                                 
: >0FONT ( to 80 cpl char mode)                                 
  ' (EMIT)   ' EMIT   EXECUTES                                  
  ' (TYPE)   ' TYPE   EXECUTES                                  
  ' (CR)     ' CR     EXECUTES ;                                
( GRAPHICS - >3FONT {3FONT}                            6/12/85) 
                                                                
HEAD: {2FONT} ( n --, EMIT routine for 7x graphics font )       
T:  @DS BLTSEG !                                                
  7 lBLT ! 32 - DUP 7SPACING + C@ wBLT ! 6 * 7CHAR + aBLT !     
  DISPLAY-WAIT BLT wBLT @ 1+ xBLT +! T;                         
: >2FONT ( select 7x graphics font)                             
  ' {2FONT} ' EMIT EXECUTES   ' {GTYPE} ' TYPE EXECUTES ;       
                                                                
HEAD: {3FONT} ( --, TYPE routine for 9x graphics font )         
T:  @DS BLTSEG !                                                
  9 lBLT ! 32 - DUP 7SPACING + C@ wBLT ! 33 - 8 * 9CHAR +       
  aBLT ! DISPLAY-WAIT BLT wBLT @ 1+ xBLT +! T;                  
: >3FONT ( select 9x graphics font)                             
  ' {3FONT} ' EMIT EXECUTES   ' {GTYPE} ' TYPE EXECUTES ;       
                                                                
( GRAPHICS - L@PIXEL, SHL-BIT                          1-08-85) 
HEX                                                             
HERE ( masks) F0 C, 0F C,                                       
CODE L@PIXEL ( y x -- color code \ @ contents of pixel)         
  0 POP  U U SUB  0 SHR  U RCL  # U ADD  2 2 SUB  U ) 2 MOV B   
  U POP  U SHL  YTABL U ADD  U ) 0 ADD  0 U MOV  DS PUSHS       
  BUF-SEG 0 MOV  0 DS LSG  U ) 0 MOV B  2 0 AND  0F # 0 TEST    
  0> NOT IF 4 # 1 MOV  0 SHR V  THEN   DS POPS  0 PUSH NEXT     
DECIMAL                                                         
                                                                
CODE SHL-BIT ( b bit -- b \ shift bit left into byte)           
  0 POP  1 POP  0 SHR  1 RCL  1 PUSH  NEXT                      
                                                                
                                                                
                                                                
                                                                
( GRAPHICS - LPLOT, LXPLOT                            12-05-85) 
HEX                                                             
CODE LPLOT ( x y -- \ plot point in current buffer)             
  2 POP 2 SHL  0 POP  YTABL 2 ADD  2 U MOV                      
  0 SHR  F0 # 2 MOV 73 C, 02 C, 0F #B 2 MOV                     
  U ) 0 ADD  0 U MOV  ES PUSHS  BUF-SEG 1 MOV  1 ES LSG         
  26 C, U ) 0 MOV B  COLOR 1 MOV B  2 1 AND B  2 COM B          
  2 0 AND B  1 0 OR B  26 C, 0 U ) MOV B  ES POPS NEXT          
                                                                
CODE LXPLOT ( x y -- \ plot xor point in current buffer)        
  2 POP 2 SHL  0 POP  YTABL 2 ADD  2 U MOV                      
  0 SHR  F0 # 2 MOV 73 C, 02 C, 0F #B 2 MOV                     
  U ) 0 ADD  0 U MOV  ES PUSHS  BUF-SEG 1 MOV  1 ES LSG         
  26 C, U ) 0 MOV B  COLOR 1 MOV B  2 1 AND B   1 0 XOR         
  26 C, 0 U ) MOV B  ES POPS NEXT                               
DECIMAL                                                         
( GRAPHICS - LLINE                                   12-05-85)  
HEX                                                             
CODE LLINE ( x2 y2 x1 y1 --, plot line in buffer)               
  Y1 POP  X1 POP  Y2 POP  X2 POP  W PUSH  I PUSH  R PUSH        
  B3 C, C3 C,  X2 0 MOV  X1 0 SUB  7D C, 04 C,  B3 C, CB C,     
  0 NEG  0 1 MOV  B7 C, C7 C, Y2 0 MOV  Y1 0 SUB  7D C, 04 C,   
  B7 C, CF C,  0 NEG  0 2 MOV  1 2 CMP  7D C, 04 C,  2 1 XCHG   
  U HI U XCHG B  ' LLINE # W MOV  A8 # W ADD  U HI W ) MOV B    
  3 # W ADD                                                     
  1 W ) MOV  1 SHR  4 # W ADD  1 W ) MOV  6 # W ADD  2 W ) MOV  
  3 # W ADD  U W ) MOV B  2 I MOV  X1 U MOV B  ES PUSHS         
  BUF-SEG 1 MOV  1 ES LSG  COLOR 1 HI MOV B  DCOLOR 1 MOV B     
  Y1 U HI MOV B  R R XOR  2 2 XOR  U HI 2 MOV B                 
  2 SHL  YTABL 2 ADD  2 W MOV  0 0 XOR  U 0 MOV B  0 SHR        
  F0 #B 2 MOV  73 C, 02 C, 0F #B 2 MOV  W ) 0 ADD  0 W MOV      
  26 C, W ) 0 MOV B  1 HI 1 XCHG B  1 2 HI MOV B  2 2 HI AND B  
( GRAPHICS - LLINE con't                              10-12-84) 
  HEX ASSEMBLER                                                 
  2 COM B 2 0 AND B 2 HI 0 OR B 26 C, 0 W ) MOV B  FE C, C3 C,  
  1111 # R ADD  1111 # R CMP  0> IF 1111 # R SUB FE C, C7 C,    
  THEN  I DEC  7D C, BD C, ES POPS R POP  I POP  W POP NEXT     
  DECIMAL                                                       
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( GRAPHICS - LFILLPOLY                                12-05-85) 
ASSEMBLER HEX CODE LFILLPOLY YMIN U MOV  YMAX U ADD  U INC      
  U SHR U SHL  SCAN U ADD  0 0 XOR  1 1 XOR  U ) 0 MOV B        
  U INC  U ) 1 MOV B  0 1 CMP  0<                               
  IF NEXT THEN  W PUSH   I PUSH  ES PUSHS  BUF-SEG 0 MOV        
  0 ES LSG  COLOR 0 MOV  0 0 HI MOV B  0 SHL B  0 SHL B         
  0 SHL B  0 SHL B  DCOLOR 1 MOV  1 2 MOV  0F #B 1 AND          
  1 0 OR B  0F #B 0 HI AND  2 SHL  2 SHL  2 SHL  2 SHL          
  2 0 HI OR B YMIN 2 MOV  1 # 2 TEST  0= NOT IF                 
  0 0 HI XCHG B  THEN  YMAX 1 MOV  1 INC  2 1 SUB  SCAN I MOV   
  2 SHL  2 I ADD  YTABL 2 ADD  2 YTAB MOV                       
  I ) 2 HI MOV B  I INC  I ) 2 MOV B  I INC                     
  YTAB W MOV  W ) U MOV  2 # W ADD  W YTAB MOV  U W MOV         
  2 HI U MOV B  U HI U HI XOR B  U SHR  U W ADD  U INC          
  2 U HI MOV B  U HI SHR B  U U HI SUB B  U PUSH 1 #B 2 HI TEST 
  0= NOT IF 0F #B U HI MOV ELSE F0 #B U HI MOV THEN             
( GRAPHICS - LFILLPOLY con't                          12-05-85) 
  ASSEMBLER HEX 1 #B 2 TEST 0= NOT                              
  IF  0F #B U MOV  ELSE  F0 #B U MOV  THEN  2 HI 2 CMP B        
  0= IF  1 #B U MOV ELSE 0F #B U HI OR  F0 #B U OR THEN         
  U 2 MOV  U POP                                                
  FF #B 2 CMP  0=  IF  FE C, C7 C, THEN  FF #B 2 HI CMP  0=     
  IF  FE C, C7 C, THEN  U PUSH  FF #B 2 HI CMP  0= NOT  IF      
  26 C,  W ) U MOV B  2 HI U HI MOV B  U HI COM B  U HI U AND B 
  0 2 HI AND B  2 HI U OR B  26 C,  U W ) MOV B  W INC  THEN    
  U POP  U HI U HI OR B  0> IF  1 PUSH  U HI 1 MOV B            
  1 HI 1 HI XOR B  REP STOS B  1 POP  THEN  1 #B 2 CMP 0= NOT   
  IF FF #B 2 CMP  0= NOT  IF 26 C, W ) U MOV B  2 U HI MOV B    
  U HI COM B  U HI U AND B  0 2 AND B                           
  2 U OR B  26 C,  U W ) MOV B  THEN  THEN 0 0 HI XCHG B        
  1 DEC  74 C, 03 C, E9 C, FF60 ,                               
  ES POPS  I POP  W POP  NEXT DECIMAL                           
( GRAPHICS - PLMOVE                                   12-05-85) 
HEX                                                             
SUB: PLMOVE ( s d len rtn -- rtn \ move pixel line from s)      
 ( to d within the current buffer for len bytes. Handles )      
 ( overlapping strings.)                                        
  RETURN POP  1 POP  W POP  I POP  ES PUSHS  DS PUSHS           
  BUF-SEG 0 MOV  0 DS LSG  0 ES LSG  I W CMP                    
  0> IF STD  1 W ADD W DEC 1 I ADD I DEC THEN  REP MOVS B  CLD  
  DS POPS  ES POPS  RETURN PUSH RET                             
DECIMAL                                                         
FORTH                                                           
                                                                
                                                                
                                                                
                                                                
                                                                
( GRAPHICS - {LCOPYBLK}                                8-23-85) 
                                                                
SUB: {LCOPYBLK} ( fulx fuly flrx flry tulx tuly rtn --)         
  ( -- fx fy tx ty dy bytes/row #rows rtn)                      
  RETURN POP                                                    
  S U MOV  8 3) 1 MOV  1 2 MOV  ( fuly)                         
  4 3) 0 MOV  0 1 SUB           ( fuly flry - = #row-1)         
  U ) 0 MOV                     ( tuly)                         
  0 2 CMP 0< IF ( if tuly>fuly)   -1 # W MOV ( row delta)       
  ELSE 1 0 SUB ( ty) 1 2 SUB ( fy) 1 # W MOV ( row delta)       
  THEN  0 4 3) MOV ( ty) 2 8 3) MOV ( fy)                       
  2 3) 2 MOV  W 2 3) MOV  6 3) 0 MOV ( flrx)                    
  2 6 3) MOV ( tx)  10 3) 0 SUB  0 SHR  2 POP                   
  0 PUSH 1 INC 1 PUSH ( #row) RETURN PUSH                       
  RET                                                           
FORTH                                                           
( GRAPHICS - LCOPYBLK                                  8-23-85) 
CODE LCOPYBLK ( fulx fuly flrx flry tulx tuly --copy pixel blk) 
  ( Assumes x locations are evenly devisible by 2.)             
  I -2 R) MOV  W -4 R) MOV                                      
  {LCOPYBLK} CALL ( -- fx fy tx ty dy bytes/row #rows)          
  S U MOV  4 3) 2 MOV ( dy) 1 POP                               
  BEGIN 1 PUSH  S U MOV  12 3) 0 MOV  0 SHR  ( fx)              
    10 3) 1 MOV  2 10 3) ADD  1 SHL  YTABL 1 ADD  1 U XCHG      
    U ) 0 ADD  1 U XCHG  0 PUSH ( s)                            
    8 3) 0 MOV  0 SHR  6 3) 1 MOV  2 6 3) ADD  1 SHL            
    YTABL 1 ADD  1 U XCHG  U ) 0 ADD  1 U XCHG  0 PUSH          
    2 3) PUSH ( s d len) PLMOVE CALL  1 POP                     
  LOOP                                                          
  12 # S ADD  -4 R) W MOV  -2 R) I MOV NEXT                     
                                                                
                                                                
                                                                
( GRAPHICS - TILEFILL                                 12-05-85) 
                                                                
CODE TILEFILL ( xul yul len width -- \ fill a rectangle at )    
  ( xul,yul with the 4x4 color pattern found at the tile addr)  
  ( Assumes xul is byte aligned and width is evenly divisible)  
  ( by 4.)                                                      
  ES PUSHS  W PUSH I PUSH R PUSH  BUF-SEG 0 MOV  0 ES LSG       
  S U MOV  14 3) 2 MOV  2 SHR  12 3) 0 MOV  0 2 HI MOV B        
  10 3) PUSH  8 3) I MOV  I SHR  I SHR  1 POP  R R XOR          
  BEGIN  1 PUSH  2 HI 0 MOV B  1 0 SUB B  CBW  0 INC  0 SHL     
    0 U MOV  YTABL U ADD  U ) W MOV  2 1 MOV B  1 HI 1 HI XOR B 
    1 W ADD  I 1 MOV  TILE-PTR U MOV  R U ADD U ) 0 MOV         
    REP STOS  2 # R ADD  7 # R AND  1 POP                       
  LOOP  R POP  I POP  W POP  ES POPS  8 # S ADD NEXT            
                                                                
                                                                
( GRAPHICS - BLK>BUFFER                               10-12-84) 
                                                                
: BLK>BUFFER  ( blk -- \ move 16 blocks to current buffer)      
  16 0 DO @DS OVER I + BLOCK                                    
         BUF-SEG @ I 1024 *                                     
         1024  LCMOVE LOOP DROP ;                               
                                                                
                                                                
                                                                
( GRAPHICS - SQLPLOT                                  12-05-85) 
HEX                                                             
CODE: SQLPLOT ( x y -- \ plot a square pixel in current buffer) 
  ( using color and dcolor.)                                    
  2 POP 2 SHL  0 POP  YTABL 2 ADD  2 U MOV  W PUSH              
  0 SHR  F0 # 2 MOV 73 C, 02 C, 0F #B 2 MOV 0 W MOV             
  U ) 0 ADD   2 # U SUB  U ) W ADD   0 U MOV  ES PUSHS          
  BUF-SEG 1 MOV  1 ES LSG                                       
  26 C, U ) 0 MOV B  COLOR 1 MOV B  2 1 AND B  2 COM B          
  2 0 AND B  1 0 OR B  26 C, 0 U ) MOV B                        
  W U MOV  2 COM B                                              
  26 C, U ) 0 MOV B  DCOLOR 1 MOV B  2 1 AND B  2 COM B         
  2 0 AND B  1 0 OR B  26 C, 0 U ) MOV B  ES POPS               
  W POP NEXT                                                    
DECIMAL                                                         
                                                                
( GRAPHICS - ARC                                       2-09-85) 
HEX                                                             
CODE ARC ( radius -- \ do vectored routine for an arc that is ) 
  ( 1/8 of a circle)                                            
  ERAD 0 MOV  0 2 MOV                                           
  0 SHL  3 # 1 MOV  0 1 SUB                                     
  0 0 XOR                                                       
  2 0 CMP 79 C, 2C C,                                           
  0 PUSH 1 PUSH 2 PUSH FF C, 16 C, <ARC> ,                      
  2 POP  1 POP  0 POP                                           
  1 1 OR 0<                                                     
  IF 6 # 1 ADD 0 U MOV U SHL U SHL U 1 ADD                      
  ELSE 0A # 1 ADD 0 U MOV  2 U SUB  U SHL U SHL U 1 ADD         
  2 DEC THEN 0 INC                                              
  EB C, 0D0 C,                                                  
  0 2 CMP 0= IF FF C, 16 C, <ARC> , THEN NEXT DECIMAL           
( GRAPHICS - {RLPLOT}                                 12-05-85) 
HEX                                                             
SUB: {RLPLOT} ( dx in 0  dy in 2 -- \ plot clipped point )      
  ( relative to origin ccx,ccy)                                 
  EY 2 ADD  EX 0 ADD  W PUSH 0 PUSH 2 PUSH                      
  VIN U MOV  2 U ) MOV  2 # U ADD  0 U ) MOV                    
  1 # U MOV  U #IN MOV  TREJECT/TACCEPT CALL                    
  2 POP 0 POP  W POP  TACCPT 1 MOV  1 1 OR 0= IF                
  2 SHL  YTABL 2 ADD  2 U MOV                                   
  0 SHR  F0 # 2 MOV 73 C, 02 C, 0F #B 2 MOV                     
  U ) 0 ADD  0 U MOV  ES PUSHS  BUF-SEG 1 MOV  1 ES LSG         
  26 C, U ) 0 MOV B  COLOR 1 MOV B  2 1 AND B  2 COM B          
  2 0 AND B  1 0 OR B  26 C, 0 U ) MOV B  ES POPS THEN RET      
DECIMAL                                                         
                                                                
                                                                
( GRAPHICS - {XASP} {.1/2} {.ELLIP}                    8-23-85) 
                                                                
SUB: {XASP} ( dx in 0 -- dx' in 0 \ adjust x by aspect ratio)   
  2 PUSH XNUMER 2 MOV  XDENOM 1 MOV  2 IMUL 1 IDIV 2 POP RET    
                                                                
SUB: {.1/2} ( dx in 0 dy in 2 -- \ reflect & plot)              
  {XASP} CALL                                                   
  0 PUSH 2 PUSH  {RLPLOT} CALL  2 POP 0 POP                     
  0 PUSH 2 PUSH  0 NEG {RLPLOT} CALL  2 POP 0 POP               
  0 PUSH 2 PUSH  0 NEG 2 NEG {RLPLOT} CALL  2 POP 0 POP         
  0 PUSH 2 PUSH  2 NEG {RLPLOT} CALL  2 POP 0 POP RET           
                                                                
SUB: {.ELLIP} ( dx in 0 dy in 2 -- \ plot full ellipse)         
  0 PUSH {.1/2} CALL  0 POP 0 2 XCHG {.1/2} CALL RET            
                                                                
                                                                
( GRAPHICS - {S1/2} {SCANELLIP}                        8-23-85) 
                                                                
SUB: {S1/2} ( x in 0 y in 2 -- \ scan 1/2 ellipse)              
  {XASP} CALL                                                   
  EX U MOV  0 U ADD  IRIGHT U CMP  0>  IF IRIGHT U MOV THEN     
  ILEFT U CMP 0< IF ILEFT U MOV U DEC THEN  U ZZZ 1+ MOV B      
  EX U MOV  0 U SUB  ILEFT  U CMP  0<  IF ILEFT  U MOV THEN     
  IRIGHT U CMP 0> IF ZZZ 1+ U MOV B U INC THEN U ZZZ MOV B      
  EY 1 MOV  2 1 ADD  IABOVE 1 CMP 0> NOT                        
  IF IBELOW 1 CMP 0< NOT                                        
  IF 1 U MOV U SHL SCAN U ADD  ZZZ PUSH U ) POP THEN THEN       
  EY 1 MOV  2 1 SUB  IBELOW 1 CMP 0< NOT                        
  IF IABOVE 1 CMP 0> NOT                                        
  IF 1 U MOV U SHL SCAN U ADD  ZZZ PUSH U ) POP THEN THEN RET   
                                                                
                                                                
( GRAPHICS - EEXTENT                                   6-17-86) 
                                                                
SUB: {SCANELLIP} ( x in 0 y in 2 -- \ scan ellipse)             
  0 PUSH {S1/2} CALL 0 POP 0 2 XCHG {S1/2} CALL RET             
CODE: EEXTENT ( -- xll yll xur yur \ compute extent for current)
  ( ellipse)                                                    
  ERAD 0 MOV  0 2 MOV  {XASP} CALL                              
  EX 1 MOV  0 1 SUB  1 PUSH                                     
  EY 1 MOV  2 1 SUB  1 PUSH                                     
  EX 1 MOV  0 1 ADD  1 PUSH                                     
  EY 1 MOV  2 1 ADD  1 PUSH NEXT                                
                                                                
                                                                
                                                                
                                                                
                                                                
( GRAPHICS - !EPARMS .ELLIPSE .CIRCLE                  6-17-86) 
                                                                
HEAD: !EPARMS                                                   
T:  ( x y radius xnumer xdenom -- \ save ellipse parms)         
 XDENOM !  XNUMER ! ERAD ! EY ! EX ! V1 VIN ! V2 OIN ! T;       
                                                                
: .ELLIPSE ( x y radius xnumer xdenom -- \ plot a clipped ellp) 
  !EPARMS                                                       
  EEXTENT  ?EXTENTX TRJCT @ 0=                                  
  IF  {.ELLIP} <ARC> ! ARC THEN ;                               
                                                                
: .CIRCLE ( x y radius -- \ plot a clipped circle)              
  9 15 .ELLIPSE ;                                               
                                                                
                                                                
                                                                
( GRAPHICS - FILLELLIP FILLCIRC                        6-17-86) 
                                                                
: FILLELLIP ( x y radius xnumer xdenom -- plot a clipped, )     
  ( filled ellipse)                                             
  !EPARMS                                                       
  EEXTENT  ?EXTENTX  TRJCT @ 0=                                 
  IF  EY @ ERAD @ + IABOVE @ MIN YMAX ! ( set limits)           
      EY @ ERAD @ - IBELOW @ MAX YMIN !                         
      {SCANELLIP} <ARC> ! ARC                                   
      LFILLPOLY THEN ;                                          
                                                                
: FILLCIRC ( x y radius -- plot a clipped, )                    
  ( filled circle)                                              
  9 15 FILLELLIP ;                                              
                                                                
                                                                
( GRAPHICS - FRAMELEN .PACKBLT                         2-11-85) 
                                                                
HEAD: FRAMELEN ( -- \ compute the length of a blt frame)        
T:  ( {color+image=frame} and save in lframe)                   
  LBLT @ WBLT @ * 15 + 16/ 2* 1+ LFRAME ! T;                    
                                                                
: .PACKBLT ( seg x y -- \ plot the packed blt at seg centered)  
  ( on x y)                                                     
  YBLT ! XBLT ! BLTSEG !                                        
  BLTSEG @ >R                                                   
  I 0 LC@ DUP LBLT ! 2/ YBLT +!                                 
  I 1 LC@ DUP WBLT ! 2/ NEGATE XBLT +! FRAMELEN                 
  R> 2 LC@ 0 DO I LFRAME @ * 3 + DUP                            
                BLTSEG @ SWAP LC@ COLOR ! 1+ ABLT !             
                BLT LOOP ;                                      
                                                                
( DDUMP - Memory dump to disk tool                     8-14-85) 
EXIT                                                            
( HEAD) : SYSKSEG ( T:) SYSK @ 64 * ( T) ;                      
( HEAD) : R0SEG ( T:) R0 @ ADDR>SEG ( T) ;                      
                                                                
( HEAD) : UPMEM  ( -- \ move @ds to sysk above sysk)            
( T:)  SYSKSEG  @DS - 0  ( #segs 0 --)                          
  DO I @DS + 0  SYSKSEG I + 0 16 LCMOVE LOOP ( T) ;             
                                                                
( HEAD) : DWNMEM ( -- \ restore mem image)                      
( T:)  SYSKSEG R0SEG  ( hi lo --)                               
  DO I' I + @DS - 0   I  0  16 LCMOVE LOOP                      
  R0SEG @DS - 0                                                 
  DO SYSKSEG I + 0   @DS I + 0  16  LCMOVE LOOP ( T) ;          
                                                                
                                                                
( DDUMP - Memory dump to disk tool                     8-14-85) 
EXIT                                                            
( HEAD) : SAVMEM ( -- \ move @ds to sysk above sysk) ( T:)      
  SYSKSEG @DS - 64 / 1+ 0  ( #blocks 0 --)                      
  DO SYSK @ I + 64 *  0 @DS I BLOCK 1024 LCMOVE UPDATE LOOP     
  SAVE-BUFFERS ( T) ;                                           
                                                                
: DDUMP ( -- \ dump memory image from data segment to sysk to)  
  ( a direct disk starting at block 0)                          
  UPMEM                                                         
  >0FONT CR ." LOAD DDUMP DISK & PRESS 'D' OR RELOAD OLD DISK AN
D PRESS ANY OTHER KEY"                                          
  KEY DUP EMIT DUP                                              
  ASCII D = SWAP ASCII d = OR                                   
  IF SAVMEM DWNMEM ELSE >LORES THEN ;                           
                                                                
\ DISPLAY SYSTEM                                                
                                                                
: SET-COLORMAP ( -- )                                           
\ Set colormap buffer based on #clrmap and monitor type.        
  MONITOR @ 1- ?DUP NOT NOT ?HERCULES NOT AND                   
  IF 1- 5 * #CLRMAP @ 1- +     \ rgb or composite               
  ELSE 3                       \ b/w or hercules                
  THEN                                                          
  FILE: CMAP LITERAL SWAP @RECORD CMAP 64 CMOVE ;               
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
CODE COLORMAP ( altitude -- )                                   
\ Set color,dcolor and tile-ptr based on altitude and           
\ current colormap.                                             
 U POP U U OR 0<                                                
 IF   0 # U MOV                                                 
 ELSE U SHR 56 # U AND                                          
 THEN                                                           
 CMAP # U ADD  U TILE-PTR MOV                                   
 0 0 XOR   U ) 0 MOV B  0 COLOR MOV                             
 2 # U ADD U ) 0 MOV B  0 DCOLOR MOV NEXT                       
                                                                
                                                                
: CELLCOLOR ( x y -- )                                          
\ Set current color based on the value in the cell x,y          
\ interpreted by way of the current color model.                
  ACELLADDR A@ COLORMAP ;                                       
                                                                
: !XYSEED ( xabs yabs -- )                                      
\ Set fractal seed based on absolute location.                  
  SEED ! FRND SWAP SEED ! FRND                                  
  GLOBALSEED @ XOR XOR SEED ! ;                                 
                                                                
                                                                
CODE BUFFERXY ( x y wlog2 hlog2 -- xul yul )                    
\ Given array cell address, log2width & log2height of           
\ the display cell, the current array region and the display    
\ buffer origin, calc the absolute display buffer location.     
  1 POP 0 POP 2 POP U POP                                       
  YLL 2 SUB  2 INC    1 1 OR 0= NOT   IF 2 SHL V THEN           
  YLLDEST 2 ADD  2 DEC                                          
  XLL U SUB  0 1 MOV  1 1 OR 0= NOT   IF U SHL V THEN           
  XLLDEST U ADD  U PUSH 2 PUSH NEXT                             
                                                                
                                                                
HEAD: .CELL ( x y -- )                                          
\ Plot cell x y from the current array using the current cell   
\ routine.                                                      
T: '.CELL @EXECUTE T;                                           
                                                                
\ : .1X1CELL ( x y -- \ plot a 1x1 pixel)                       
\   ( cell )                                                    
\   2DUP CELLCOLOR          ( x y --)                           
\   0 0 BUFFERXY            ( x' y' --)                         
\   LPLOT ;                                                     
                                                                
: .1X2CELL ( x y -- )                                           
\ Plot a 1x2 pixel cell.                                        
  2DUP CELLCOLOR          ( x y --)                             
  0 1 BUFFERXY            ( x' y' --)                           
  SQLPLOT ;                                                     
                                                                
: .2X2CELL ( x y -- )                                           
\ Plot a 2x2 pixel cell.                                        
  2DUP CELLCOLOR          ( x y --)                             
  1 1 BUFFERXY            ( x' y' --)                           
  2DUP SQLPLOT                                                  
  SWAP 1+ SWAP SQLPLOT ;                                        
                                                                
                                                                
: .4X4CELL ( x y -- )                                           
\ Plot a 4x4 pixel cell.                                        
  2DUP CELLCOLOR          ( x y --)                             
  2 2 BUFFERXY            ( x' y' --)                           
  4 4 TILEFILL ;                                                
                                                                
: .8X8CELL ( x y -- )                                           
\ Plot an 8x8 pixel cell.                                       
  2DUP CELLCOLOR          ( x y --)                             
  3 3 BUFFERXY            ( x' y' --)                           
  8 8 TILEFILL ;                                                
                                                                
                                                                
: .REGION ( -- )                                                
\ Plot the current region of the current array into the         
\ current buffer at the current destination using the           
\ current cell plot routine and the current color model.        
  YUR @ 1+ YLL @ DO \ for each row                              
  XUR @ 1+ XLL @ DO \ for each col                              
                 I J .CELL                                      
                 LOOP LOOP ;                                    
                                                                
                                                                
CODE ?INVIS  ( xwld ywld -- t )                                 
\ Is location in the current visible world window?.             
  0 0 SUB   2 POP                                               
  BVIS 2 CMP 0< IF 4 # 0 OR THEN \ below?                       
  TVIS 2 CMP 0> IF 8 # 0 OR THEN \ above?                       
  2 POP                                                         
  LVIS 2 CMP 0< IF 1 # 0 OR THEN \  left?                       
  RVIS 2 CMP 0> IF 2 # 0 OR THEN \ right?                       
  0 0 OR 0= IF 0 INC ELSE 0 0 XOR THEN 0 PUSH NEXT              
                                                                
                                                                
CODE WLD>SCR ( xwld ywld -- xscr yscr )                         
\ Convert world coords to display coords.                       
  0 POP  BVIS 0 SUB   YWLD:YPIX 1 MOV    1 IMUL                 
                      YWLD:YPIX 2+ 1 MOV 1 IDIV                 
  YLLDEST 0 ADD  0 ZZZ MOV                                      
  0 POP  LVIS 0 SUB   XWLD:XPIX 1 MOV    1 IMUL                 
                      XWLD:XPIX 2+ 1 MOV 1 IDIV                 
  XLLDEST 0 ADD  0 PUSH  ZZZ PUSH NEXT                          
                                                                
                                                                
CODE SCR>BLT ( xscr yscr -- xblt yblt )                         
\ Convert display coords to centered blt coords.                
  0 POP  7 # 0 ADD  CENTERADJUST 0 SUB                          
  1 POP             CENTERADJUST 1 SUB                          
  1 PUSH 0 PUSH NEXT                                            
                                                                
                                                                
: !VISWINDOW ( l b r t -- )                                     
\ Set visible world clipping window.                            
  TVIS ! RVIS ! BVIS ! LVIS ! ;                                 
                                                                
                                                                
HEAD: FILE>ICONIMAGE ( file# -- )                               
\ Move icon blt images to iconimage.                            
T: 64 0 DO @DS OVER I @RECORD                                   
           0 I ICONIMAGE 18 LCMOVE                              
        LOOP DROP T;                                            
                                                                
: >1ICONFONT ( -- )                                             
\ Set up for full scale icon display.                           
  1 ICONFONT ! CENTERADJUST OFF  62 FILE>ICONIMAGE ;            
                                                                
: >2ICONFONT ( -- )                                             
\ Set up for 1/2 scale icon display.                            
  2 ICONFONT ! 2 CENTERADJUST !  63 FILE>ICONIMAGE ;            
( 12-05-85)                                                     
: >3ICONFONT ( -- )                                             
\ Set up for 1/4 scale icon display.                            
  3 ICONFONT ! 3 CENTERADJUST !  64 FILE>ICONIMAGE ;            
                                                                
CODE: @IW ( seg -- n )                                          
\ @ word indexed by iindex relative to seg.                     
  0 POP  ES PUSHS  0 ES LSG  IINDEX U MOV  U SHL                
  ES SEG U ) 0 MOV  ES POPS  0 PUSH NEXT                        
                                                                
CODE: @IB ( seg -- c )                                          
\ @ byte indexed by iindex relative to seg.                     
  0 POP  ES PUSHS  0 ES LSG  IINDEX U MOV  0 0 XOR              
  ES SEG U ) 0 MOV B  ES POPS  0 PUSH NEXT                      
                                                                
CODE !IW ( n seg -- )                                           
\ ! word indexed by iindex relative to seg. 12-05-85            
  0 POP  1 POP  ES PUSHS  0 ES LSG  IINDEX U MOV  U SHL         
  ES SEG 1 U ) MOV  ES POPS  NEXT                               
                                                                
CODE !IB ( c seg -- )                                           
\ ! byte indexed by iindex relative to seg.                     
  0 POP  1 POP  ES PUSHS  0 ES LSG  IINDEX U MOV                
  ES SEG 1 U ) MOV B  ES POPS  NEXT                             
                                                                
\ access icon indexed by iindex.                                
: @IX ( -- x )       IXSEG @ @IW ;                              
: @IY ( -- y )       IYSEG @ @IW ;                              
: @ID ( -- icon-id ) IDSEG @ @IB ;                              
: @IC ( -- icon-clr) ICSEG @ @IB ;                              
: @IL ( -- lo-iaddr) ILSEG @ @IW ;                              
: @IH ( -- hi-iaddr) IHSEG @ @IB ;                              
                                                                
: !IX ( x -- )       IXSEG @ !IW ;                              
: !IY ( y -- )       IYSEG @ !IW ;                              
: !ID ( icon-id  --) IDSEG @ !IB ;                              
: !IC ( icon-clr --) ICSEG @ !IB ;                              
: !IL ( lo-iaddr --) ILSEG @ !IW ;                              
: !IH ( hi-iaddr --) IHSEG @ !IB ;                              
                                                                
                                                                
: INIT-ICONLIST ( -- )                                          
\ Initialize iconlist array.                                    
  IGLOBAL OFF ILOCAL OFF ;                                      
                                                                
: .BACKGROUND ( -- )                                            
\ Plot background using the current plot routine.               
  '.BACKGROUND @EXECUTE ;                                       
                                                                
                                                                
HEAD: {8X8ICON} ( n -- )                                        
\ Plot blt n .                                                  
T: 0 SWAP ICONIMAGE ABLT ! BLTSEG !                             
   2 0 DO                                                       
       BLTSEG @ ABLT @ LC@ !COLOR                               
       1 ABLT +! BLT  8 ABLT +!                                 
       LOOP T;                                                  
                                                                
                                                                
HEAD: .8X8ICON ( -- )                                           
\ Display the set-icon using it's id# as an index into          
\ the 8X8 blt table and add dead marker if applicable.          
T: 8 8 WBLT ! LBLT !                                            
  @IX @IY WLD>SCR SCR>BLT YBLT ! XBLT ! @ID {8X8ICON}           
  @IC DEAD-IC = IF 19 {8X8ICON} THEN T;                         
                                                                
                                                                
HEAD: .FLUX-ICON ( -- )                                         
\ Plot flux icon effect.                                        
T: '.FLUX-ICON @EXECUTE T;                                      
                                                                
HEAD: .CIRCLEICON ( -- )                                        
\ Display current circle icon.                                  
T: @IC !COLOR @IX @IY WLD>SCR                                   
   @ID NULL-ICON - *MAPSCALE *                                  
   YWLD:YPIX D@ SWAP */ FILLCIRC T;                             
                                                                
                                                                
CASE SYSCASES ( color -- *bltseg-pfa )                          
  RED    IS SSYSEG   \ small starsystem blt                     
  ORANGE IS SSYSEG   \ medium starsystem blt                    
  WHITE  IS MSYSEG   \ medium starsystem blt                    
  YELLOW IS MSYSEG   \ medium starsystem blt                    
OTHERS LSYSEG        \ large starsystem blt                     
                                                                
                                                                
HEAD: .STARSYS ( -- )                                           
\ Display a star system icon.                                   
T:  @IC SYSCASES @ @IX @IY WLD>SCR .PACKBLT T;                  
                                                                
                                                                
CASE .ICONCASES  ( icon-id -- )                                 
  SYS-ICON   IS .STARSYS                                        
  NULL-ICON  IS NOP                                             
  FLUX-ICON  IS .FLUX-ICON                                      
  INVIS-ICON IS NOP                                             
OTHERS .CIRCLEICON  \ nebula, stars, planets)                   
                                                                
                                                                
: .ICON ( -- )                                                  
\ Display the current icon using current display                
\ parameters.                                                   
 @IX @IY ?INVIS               \ in the vis area?                
  @ID 51 91 WITHIN OR           \ or a filled circle            
  IF @ID NULL-ICON <                                            
    IF .8X8ICON ELSE @ID .ICONCASES THEN                        
  THEN ;                                                        
                                                                
                                                                
: POINT>ICON ( n -- )                                           
\ Set icon pointer to icon # n.                                 
 IINDEX ! ;                                                     
( 12-05-85)                                                     
                                                                
: .LOCAL-ICONS ( -- )                                           
\ Display all visible icons in the local portion of the         
\ icon display list using the current parms.                    
  ILOCAL @ ?DUP IF 0 DO I POINT>ICON .ICON LOOP THEN ;          
                                                                
                                                                
CODE: ?ILOCUS ( x y radius base qty -- nnnnn...nnn cnt )        
\ Find all icons not greater than radius from x y in            
\ 1st qty icons following base icon.                            
  1 POP BICON POP RLOCUS POP  YLOCUS POP  XLOCUS POP            
  0 0 XOR  0 PUSH                                               
  1 1 OR 0>                                                     
  IF BEGIN                                                      
       1 U MOV  U DEC  BICON U ADD  U SHL  \ offset addr        
       ES PUSHS                                                 
       IXSEG PUSH  ES POPS                                      
       ES SEG U ) 2 MOV                    \ xwld               
       ES POPS                                                  
       XLOCUS 2 SUB                                             
       0< IF 2 NEG THEN                    \ xdist              
       RLOCUS 2 CMP                                             
       0> NOT IF ES PUSHS                                       
                 IYSEG PUSH  ES POPS                            
                 ES SEG U ) 2 MOV          \ ywld               
                 ES POPS                                        
                 YLOCUS 2 SUB                                   
                 0< IF 2 NEG THEN          \ ydist              
                 RLOCUS 2 CMP  0> NOT      \ <= radius?         
                 IF 0 POP U SHR U PUSH                          
                    0 INC 0 PUSH                                
                 THEN                                           
              THEN                                              
     LOOP                                                       
  THEN NEXT                                                     
                                                                
                                                                
: ?ICONS-LOCUS ( x y radius qty -- nnnnn...nnn cnt )            
\ Assumes base is beginning of icon list.                       
  0 SWAP ?ILOCUS ;                                              
                                                                
                                                                
: ?ICONS-AT ( x y qty -- nnnn ct )                              
\ Find icons with the given x,y and leave a count.              
\ Search through 1st qty icons.                                 
  0 SWAP ?ICONS-LOCUS ;                                         
                                                                
                                                                
: ?ICON=IADDR ( iaddr -- n 1 or 0 )                             
\ Locate icon number of icon with iaddr.                        
\ Flag indicates if found.                                      
  0 IGLOBAL @   ( ilo ihi offset cnt -- )                       
  BEGIN                                                         
    ILSEG @ ROT ROT        ( ilo ihi seg off cnt -- )           
    5 PICK LWSCAN          ( ilo ihi off 1 or " 0 -- )          
    IF IHSEG @ OVER 2/ LC@ ( ilo ihi off ihi' -- )              
       3 PICK = IF   1            \ set found flag              
                ELSE 2+ IGLOBAL @ ( ilo ihi off' n -- )         
                     OVER 2/ -    ( ilo ihi off' cnt' -- )      
                     0            \ not found - repeat          
                THEN                                            
    ELSE -1 1 ( ilo ihi -1 1 -- ) \ not found - end             
    THEN                                                        
  UNTIL                                                         
  >R 2DROP R>                                                   
  DUP 0< IF DROP 0 ELSE 2/ 1 THEN ;                             
                                                                
                                                                
CODE: XCHGICON ( n n' -- )                                      
\ Exchange the contents of locations n and n' in the icon       
\ display list                                                  
  0 POP  U POP                                                  
  ES PUSHS  IDSEG PUSH  ES POPS  {LCXCHG} CALL                  
            ICSEG PUSH  ES POPS  {LCXCHG} CALL                  
            IHSEG PUSH  ES POPS  {LCXCHG} CALL                  
  0 SHL  U SHL                                                  
            IXSEG PUSH  ES POPS  {LXCHG} CALL                   
            IYSEG PUSH  ES POPS  {LXCHG} CALL                   
            ILSEG PUSH  ES POPS  {LXCHG} CALL                   
  ES POPS NEXT                                                  
                                                                
                                                                
HEAD: PERCOLATE ( nnn...nn cnt base -- )                        
\ Exchange the stacked icons with the 1st cnt icons             
\ following base.                                               
\ Stacked icons must be in reverse counting order.              
T: BICON ! ?DUP IF 0 DO I BICON @ + XCHGICON LOOP               
                THEN T;                                         
                                                                
                                                                
: -ICON ( -- )                                                  
\ Delete the icon list entry for the current instance.          
  CI ?ICON=IADDR    ( n 1 or 0 --)                              
  IF ILOCAL @ OVER >                                            
     IF -1 ILOCAL +! ILOCAL @ DUP >R XCHGICON R> THEN           
     -1 IGLOBAL +!  IGLOBAL @ XCHGICON                          
  THEN ;                                                        
                                                                
( 12-05-85)                                                     
CODE: ?IID ( min-id max-id base qty -- nnnnn cnt )              
\ Stack all icons found in the 1st qty icons following base     
\ whose type id byte is greater than min-id and less than       
\ max-id.                                                       
  1 POP  BICON POP  2 POP  ZZZ 2+ POP  0 0 XOR                  
  ES PUSHS  ZZZ POP  IDSEG PUSH  ES POPS  0 PUSH  1 1 OR 0> IF  
  BEGIN                                                         
    1 U MOV  U DEC  BICON U ADD  ES SEG U ) 0 MOV B             
    2 0 CMP 0<                                                  
    IF ZZZ 2+ 0 CMP 0>                                          
       IF 0 POP  U PUSH  0 INC  0 PUSH  0 0 XOR THEN            
    THEN                                                        
  LOOP THEN ZZZ PUSH  ES POPS NEXT  ( 12-05-85)                 
                                                                
                                                                
: ?ICONSID ( min-id max-id qty -- nnnnn cnt )                   
\ Stack all icons found in the 1st qty icons                    
\ whose type id byte is greater than min-id and less than       
\ max-id.                                                       
 0 SWAP ?IID ;                                                  
                                                                
                                                                
: +ICON ( x y id clr iaddr -- )                                 
\ Append an icon to the display list.                           
  IGLOBAL @ DUP ILIMIT =                                        
  IF UNRAVEL THEN POINT>ICON 1 IGLOBAL +!                       
  !IH !IL !IC !ID !IY !IX ;                                     
                                                                
                                                                
: +ICONBOX ( -- )                                               
\ Append all icons in the current box.                          
  'ICONBOX @ MODULE ;                                           
                                                                
                                                                
: ORGLIST ( -- )                                                
\ Organize display list if distance to anchor is greater than   
\ LOCRADIUS and drop new anchor and make new local/non-local    
\ partition. If in space get all circular icons that overlap    
\ on local area and make them 1st in the list so that they      
\ are drawn 1st. Make the ship or the terrain vehicle last      
\ in the list.                                                  
  ANCHOR 2@  YABS @  - ABS SWAP XABS @ - ABS                    
  MAX LOCRADIUS @ - 0>                                          
  IF XABS @ YABS @ 2DUP ANCHOR 2!      \ new anchor             
     CONTEXT-ID# @           \ in space?                        
     IF LOCRADIUS @ MXCIRC @ + IGLOBAL @ ?ICONS-LOCUS           
        \ ident icons in extended radius                        
        DUP ILOCAL ! 0 PERCOLATE \ save count & make them 1st   
        NULL-ICON SYS-ICON ILOCAL @ ?ICONSID \ ident circles    
        DUP #CIRC ! 0 PERCOLATE  \ save count & make them 1st   
        ANCHOR 2@ LOCRADIUS @ #CIRC @ ILOCAL @ OVER -           
        ?ILOCUS    \ ident icons in restricted radius           
        DUP #CIRC @ + ILOCAL ! \ adjust local icon count        
        #CIRC @ PERCOLATE      \ move below circles             
     ELSE                                                       
        LOCRADIUS @ IGLOBAL @ ?ICONS-LOCUS                      
        \ ident icons in restricted radius                      
        DUP ILOCAL ! 0 PERCOLATE \ save count & make them 1st   
     THEN                                                       
     25 35 ILOCAL @ ?ICONSID \ make tv & spaceship last local   
     ?DUP IF 0 DO ILOCAL @ 1- XCHGICON LOOP THEN                
  THEN ;                                                        
                                                                
exit ***************************************                    
: SEELIST ( start end -- )                                      
\ Display iconlist from start to end.                           
  CR ."    X    Y  ID  IC   IADR"                               
  1+ SWAP DO I POINT>ICON                                       
  CR @IX 4 .R @IY 5 .R @ID 4 .R                                 
  @IC 4 .R  @IL @IH 7 D.R LOOP ;                                
                                                                
: TESTICONS ( start end -- )                                    
\ Initialize some testing icons.                                
  1+ SWAP DO I POINT>ICON                                       
  I !IX  I !IY I !ID I !IC I !IL 0 !IH LOOP ;                   
                                                                
\ MAKE SLIDE PICTURE                                            
EXIT                                                            
V: PICNUM \ picture filename incrementer                        
1 picnum !                                                      
                                                                
HEAD: MKPIC ( -- )                                              
\ Make a slide file on current directory.                       
T:  PAD 60 + 'FCB ! CLRFCB                                      
  PICNUM @ 0 <# #S #> NAM SWAP CMOVE                            
  " PIC" TYP SWAP CMOVE                                         
  MAKE 0= IF BUF-SEG @ 0 DTA 2! DOS-DTA                         
             16384 RECSIZE ! WRITENEXT CLOSE OR                 
             1 PICNUM +!                                        
          ELSE 1                                                
          THEN                                                  
  IF BEEP THEN T;                                               
(              Interstel Logo Word                             )
                                                                
: POS. ( x y -- \ store blt location )                          
  YBLT ! XBLT ! ;                                               
                                                                
: .1LOGO ( x y -- \ plot interstel logo)                        
 @COLOR >R !COLOR POS.  @DS BLTSEG !                            
 10 lBLT ! 10 wBLT ! 1LOGO aBLT ! BLT                           
 R> !COLOR ;                                                    
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ music - ms! ms@ msc@ msc! muson musoff song                   
head: mussegswap t: musseg swap t;                              
head: ms!  ( n offset -- ) t: mussegswap l! t;                  
head: ms@  ( offset -- n ) t: mussegswap l@ t;                  
head: msc@ ( offset -- c ) t: mussegswap lc@ t;                 
head: msc! ( c offset -- ) t: mussegswap lc! t;                 
head: muson ( -- ) t: 1 2 ( ?music) msc! t;                     
head: musoff ( -- ) t: 0 2 ( ?music) msc! beepoff t;            
: song ( n -- )                                                 
\ Set up and start the playing of song n.                       
 ?sound @ if musoff 2* 16 ( songs) + ms@   ( songoffset --)     
 dup dup  3 ( phrase0) ms!  5 ( currphr) ms!                    
 dup msc@ 9 ( repeats) msc!                                     
 1+ ms@   7 ( curnote) ms!                                      
 1 10 ( counter)   msc!                                         
 1 13 ( tonestate) msc!   muson then ;                          
\ sound routines                                  ( rfg11feb86) 
                                                                
?sound on \ global, changed by 'front panel'                    
150 beepms !                                                    
: @beep beeptone @ beepms @ ;                                   
: !beep beepms <!> beeptone <!> ;                               
\ : beep ?sound @ if BEEPMS @ 54 / BEEPTICKS ! beep then ;      
                                                                
: click                                                         
 @beep 100 beepms ! 50 beeptone ! beep !beep ;                  
                                                                
: >SND ( [n n'] cnt -- )                                        
 0 ?SOUND @                                                     
 IF 1 TONE BEEPON DO TONE MS LOOP BEEPOFF                       
 ELSE DO 2DROP LOOP THEN ;                                      
: BEEPON ?SOUND @ IF BEEPON THEN ;                              
( Poly Initializer                     AWK 06/20/84 )           
                                                                
HEAD: INIT-VIEWSCREEN-POLY ( -- )                               
T: NEB-TABLE VIN ! NEB2 VOUT ! V1 OIN ! V2 OOUT ! T;            
                                                                
HEAD: POLY-WINDOW-BOUND ( y0 x0 y1 x1 c -- )                    
T: INIT-VIEWSCREEN-POLY !COLOR NEB-TABLE >R                     
 DUP I 2+ ! I 14 + ! DUP I ! I 4 + !                            
 DUP I 6 + ! I 10 + ! DUP I 8 + ! R> 12 + ! 4 #IN ! T;          
                                                                
: POLY-WINDOW-FILL ( y0 x0 y1 x1 c -- )                         
 POLY-WINDOW-BOUND SCANPOLY LFILLPOLY ;                         
                                                                
: sfill ( -- ) 199 NULL 159 @color poly-window-fill ;           
                                                                
                                                                
( Support Words for Window Scrolling                          ) 
                                                                
: @CRS ( -- )                                                   
 yBLT @ xBLT @ lBLT @ wBLT @ aBLT @ NCRS @ OCRS @ COLOR @       
 DCOLOR @ XORMODE @ BLTSEG @ ;                                  
                                                                
: !CRS ( -- ) BLTSEG !                                          
 XORMODE ! DCOLOR ! COLOR ! OCRS ! NCRS ! aBLT ! wBLT ! lBLT !  
 xBLT ! yBLT ! ;                                                
\ routines to save the cursor BLT et al. state.                 
                                                                
: $. ( $addr -- )   COUNT TYPE ;                                
  \ $addr is the address of a packed string.                    
                                                                
                                                                
                                                                
( Text Output                                     AWK  7/14/86 )
                                                                
: POLY-ERASE-TEXT ( n c -- )                                    
 >R >R @CRS yBLT @ DUP 4 - xBLT @ SWAP OVER R> 4 * + R>         
 POLY-WINDOW-FILL !CRS ;                                        
\ erase n characters from screen starting at current position   
\ and using color c.                                            
                                                                
: POS.PXT ( n c y x -- )                                        
 >R >R >R >R @CRS R> R> R> R>                                   
 SWAP POS. POLY-ERASE-TEXT !CRS ;                               
\ like POLY-ERASE-TEXT, but start erase at position x y         
                                                                
                                                                
                                                                
                                                                
( Window Words  WINDOW .WNEXT .WPREV             AWK  7/15/85 ) 
                                                                
: WINDOW ( top left #lines #chars -- )                          
 DUP WCHARS ! 4 * ROT DUP WLEFT ! + WRIGHT !                    
 DUP WLINES ! 1- -7 * 5 - OVER + WBOTTOM ! WTOP ! ;             
\ initialize scrolling window area                              
HEAD: .WNEXT ( $addr -- )                                       
T: >R @CRS XORMODE OFF >1FONT                                   
 WLEFT @ WBOTTOM @ 5 + POS. R> $. !CRS T;                       
HEAD: .WPREV ( $addr -- )                                       
T: >R @CRS XORMODE OFF >1FONT                                   
 WLEFT @ WTOP @ POS. R> $. !CRS T;                              
\ output packed strings at appropriate places see WLINE-UP/DOWN 
                                                                
                                                                
                                                                
( Window Words  WLINE-UP WLINE-DOWN              AWK 10/02/84 ) 
: WLINE-UP ( $addr -- )                                         
 7 0 DO WLEFT @ WTOP @ 1- WRIGHT @ WBOTTOM @ 1-                 
 WLEFT @ WTOP @ LCOPYBLK LOOP .WNEXT ;                          
: WLINE-DOWN ( $addr -- )                                       
 7 0 DO WLEFT @ WTOP @ 1+ WRIGHT @ WBOTTOM @                    
 WLEFT @ WTOP @ LCOPYBLK LOOP .WPREV ;                          
\ fine scroll one text line and output packed string $addr.     
                                                                
: GCR ( -- )  -7 yBLT +! WLEFT @ xBLT ! ;                       
\ graphics CR -- CR's to left side of window & one line lower   
                                                                
: WSHORTEN ( c -- )                                             
 WCHARS @ SWAP 7 WBOTTOM +! WBOTTOM @ 2- WLEFT @ POS.PXT        
 -1 WLINES +! ;                                                 
\ shorten window one line; erase old bottom line with color c.  
( Starship Console Utilities                                  ) 
V= CTTOP V= CTBOT                                               
: >SSCT ( -- )  50 CTTOP ! 3 CTBOT ! ; >SSCT                    
: >TVCT ( -- )  WTOP @ CTTOP ! WBOTTOM @ CTBOT ! ;              
                                                                
: CTPOS. ( x y -- )                                             
 2DUP CTY ! CTX ! SWAP 4 * 5 + CTTOP @ ROT 7 * - POS. ;         
\ console-text graphics char & line position                    
                                                                
: CTERASE ( -- )                                                
 @COLOR 51 3 1 156 BLACK POLY-WINDOW-FILL 0 0 CTPOS. !COLOR ;   
\ erase console-text with black                                 
                                                                
                                                                
                                                                
                                                                
( TEXT - CTCR TTY-SCROLL .TTY                          4-22-86) 
: CTCR ( -- )   0 CTY @ 1+ 6 MIN CTPOS. ;                       
\ console-text CR (different from GCR; positions one pixel      
\ right of WLEFT and one raster line below WTOP).               
                                                                
: TTY-SCROLL ( -- \ scroll text window up 1 line)               
  7 0 DO 3 49 161 3 3 50 LCOPYBLK LOOP ;                        
HEAD: CRTTY ( -- \ CR for tty mode)                             
T: >1FONT TTY-SCROLL 0 6 CTPOS. T;                              
: CTINIT ( -- )                                                 
\ console-text initialization                                   
  >1FONT XORMODE OFF WHITE !COLOR ' CRTTY ' CR EXECUTES ;       
                                                                
: .TTY ( addr cnt -- \ cr and output text tty style)            
  CRTTY TYPE ;                                                  
                                                                
( Starship Console: VIEWSCREEN  TXT-WINDOW         1/23/86 AWK) 
: VIEWSCREEN  ( c -- ) \ c is fill-color                        
 3 0 DO         \ vs graphics (uses current color for llines )  
   I 1+ 195 OVER 68 LLINE 76 I + 195 OVER 68 LLINE              
 LOOP                                                           
 4 0 DO                                                         
   4 68 I + 75 OVER LLINE      4 192 I + 11 OVER LLINE          
   75 192 I + 68 OVER LLINE                                     
 LOOP 74 192 12 OVER LLINE @COLOR SWAP !COLOR                   
 >MAINVIEW BFILL >DISPLAY V>DISPLAY !COLOR ;                    
                                                                
: TXT-WINDOW \ text-window graphics (uses current color)        
 ?ON-PLAN @ 13 * >V                                             
 2 0 DO I 1+ VI OVER 52 VI + LLINE                              
     157 I + VI OVER 52 VI + LLINE LOOP                         
 3 52 VI + 156 OVER LLINE 3 VI 156 V> LLINE ;                   
( Starship Console: AUXSCREEN  BTN-WINDOW          6/11/86 AWK )
                                                                
HEAD: AUXSCREEN \ auxscreen gr. (current color)                 
T: 2 0 DO                                                       
   81 I + 125 OVER 198 LLINE                                    
   157 I + 125 OVER 198 LLINE                                   
 LOOP                                                           
 83 198 156 OVER LLINE 83 125 156 OVER LLINE T;                 
                                                                
HEAD: BTN-WINDOW \ button window-graphics (current color)       
T: 2 0 DO                                                       
   90 I + 55 OVER 122 LLINE                                     
   157 I + 55 OVER 122 LLINE                                    
 LOOP                                                           
 92 122 156 OVER LLINE 92 55 156 OVER LLINE T;                  
                                                                
( Starship Console Frame Things: Button BLTs      07/14/86 AWK )
                                                                
HEAD: .BUTTONS ( -- )                                           
T: BUTTON aBLT ! 9 lBLT ! 8 wBLT ! XORMODE OFF @DS BLTSEG !     
 6 0 DO 81 120 I 11 * - POS. BLT LOOP 1 65 GREY2 .1LOGO T;      
                                                                
\ BLTS for buttons                                              
                                                                
: ?MRC ( mono rgb composite -- monitor-color )                  
\ Select color based on monitor type.                           
  monitor @ dup                                                 
  3 = if drop rot rot                                           
      else 2 = if rot then                                      
      then                                                      
  2drop ;                                                       
                                                                
( Starship Console Controls  Erase Screens        10/23/84 AWK )
                                                                
HEAD: ERASE-BUTTONS ( c -- )                                    
T: >R @COLOR 121 92 56 156 R> POLY-WINDOW-FILL !COLOR T;        
                                                                
: ERASE-AUXILLARY ( c -- )                                      
 >R @COLOR 197 83 126 156 R> POLY-WINDOW-FILL !COLOR ;          
                                                                
: ERASE-TEXT ( c -- )                                           
 >R @COLOR 51 3 1 156 R> POLY-WINDOW-FILL 0 0 CTPOS. !COLOR ;   
                                                                
HEAD: ERASE-VS ( c -- )                                         
T: @COLOR SWAP !COLOR >MAINVIEW BFILL                           
 >DISPLAY V>DISPLAY !COLOR T;                                   
                                                                
\ erase screens using color c                                   
( Starship Console                                3/10/86 AWK ) 
                                                                
HEAD: YBUTTON ( c y# -- )                                       
T: 11 * 82 119 ROT - POS. !COLOR XORMODE OFF T;                 
                                                                
: .HIGHLIGHT ( c y# -- ) @DS BLTSEG !                           
 YBUTTON HIGHLIGHT-BUTTON aBLT ! 7 lBLT ! 6 wBLT ! BLT ;        
                                                                
HEAD: (.ON) ( c y# -- )                                         
 T: @DS BLTSEG !                                                
 YBUTTON -2 yBLT +! 2 xBLT +!                                   
 3 lBLT ! 2 wBLT ! BUTTON-ON aBLT ! BLT T;                      
                                                                
: .ON ( c y# -- ) OVER >R (.ON) R> IF CLICK THEN ;              
                                                                
\ graphics support for using buttons during play                
( Starship Console                                7/14/86 AWK ) 
: CLR-BUTTONS ( -- )                                            
 6 0 DO 0 I 2DUP .HIGHLIGHT (.ON) LOOP ;                        
                                                                
: INIT-BUTTON ( -- )                                            
 CLR-BUTTONS THIS-BUTTON OFF BLUE 0 .HIGHLIGHT ;                
                                                                
: (SHIP-CONSOLE) ( vs-color -- )                                
 >SSCT GREY1 !COLOR sfill GREEN GREEN DK-BLUE ?MRC !COLOR       
 VIEWSCREEN AUXSCREEN BTN-WINDOW TXT-WINDOW .BUTTONS            
 0 ERASE-BUTTONS BLACK ERASE-AUXILLARY CTERASE                  
 CLR-BUTTONS INIT-BUTTON ;                                      
                                                                
: SHIP-CONSOLE ( -- ) BLACK (SHIP-CONSOLE) ;                    
\ draw the entire ship console (precede this with >LORES if in  
\ text mode).                                                   
( General Cursor Words   XYSCAN                  AWK 06/11/86 ) 
: 'KEY ( -- n ) ?TERMINAL IF                                    
   LKEY @ SKEY ! KEY DUP LKEY !                                 
   DUP 27 = ESC-EN @ AND IF DROP 0 ESC-PFA @EXECUTE THEN        
   DUP 19 = IF DROP 0 ?SOUND 1 TOGGLE                           
               ?sound @ 0= if musoff then                       
            THEN                                                
   \ DUP 16 = IF DROP 0 MKPIC THEN                              
   KEYTIME 2@ LKEYTIME 2! TIME 2@ KEYTIME 2! ELSE 0 THEN ;      
HEAD: UL T:              1 -1   T;                              
HEAD: U0 T:              1  0   T;                              
HEAD: UR T:              1  1   T;                              
HEAD: 0L T:              0 -1   FQUIT ON T;                     
HEAD: 0R T:              0  1   FQUIT ON T;                     
HEAD: DL T:             -1 -1   T;                              
                                                                
( General Cursor Words   ?TRIG ?QUIT Y/N         AWK 06/17/86 ) 
HEAD: DZ T:             -1  0   T;                              
HEAD: DR T:             -1  1   T;                              
HEAD: XY0 T:    NULL  (  0  0 ) T;                              
HEAD: TRIG T:   NULL  (  0  0 ) FTRIG ON T;                     
CASE (XYSCAN) ( n -- dy dx )                                    
  327 IS UL   328 IS U0   329 IS UR                             
  331 IS 0L               333 IS 0R                             
  335 IS DL   336 IS DZ   337 IS DR    0 IS XY0                 
   92 IS UL   126 IS U0 ( 329 IS UR )           \ for Tandy &   
  124 IS 0L               500 IS 0R             \ other numeric 
  335 IS DL    96 IS DZ ( 337 IS DR )           \ keypads       
OTHERS TRIG                                                     
: XYSCAN ( -- dy dx )  FQUIT OFF FTRIG OFF 'KEY (XYSCAN) ;      
: ?TRIG ( -- f )  FTRIG @ DUP IF FTRIG OFF THEN ;               
: ?QUIT ( -- f )  FQUIT @ DUP IF FQUIT OFF THEN ;               
( 'Flight Button tasking                         AWK 12/21/84 ) 
                                                                
: Y/N ( -- f ) BEGIN XYSCAN SWAP DROP ?DUP UNTIL CLICK 0> ;     
                                                                
HEAD: NEXT-BUTTON ( -- ) T: 93 xBLT ! -11 yBLT +! T;            
HEAD: XEQ-BUTTON ( n -- )  T:  'BUTTON @EXECUTE T;              
                                                                
: .ABTN ( menu# btn# -- )                                       
 >R 58 FILE# ! RECORD# ! 93 119 I 11 * - POS. >2FONT            
 yBLT @ 93 OVER 7 - 156 BLACK POLY-WINDOW-FILL                  
 WHITE !COLOR 1BTN R> 12 * + 12 TYPE SET-CURRENT ;              
                                                                
                                                                
                                                                
                                                                
                                                                
( 'Flight Button tasking                         AWK 12/21/84 ) 
                                                                
: .BTN-TEXT ( menu# -- )                                        
 58 FILE# ! DUP RECORD# ! BTN-REC# !                            
 BLACK ERASE-BUTTONS 93 119 POS. >2FONT WHITE !COLOR            
 #BTN C@ 12 * 0 DO 1BTN I + 12 TYPE NEXT-BUTTON 12 +LOOP        
 SET-CURRENT ;                                                  
                                                                
: NEW-BUTTON ( n -- )                                           
 58 FILE# ! BTN-REC# @ RECORD# !                                
 THIS-BUTTON @ SWAP - DUP 0 #BTN C@ WITHIN                      
 IF BLUE OVER BLACK THIS-BUTTON @ .HIGHLIGHT .HIGHLIGHT         
 THIS-BUTTON ! CLICK ELSE DROP THEN SET-CURRENT ;               
                                                                
                                                                
                                                                
( CURSOR -  DOCUMENTATION                              3-06-85) 
EXIT                                                            
  Cursors are created by making a table that defines the legal  
  locations for a moving cursor. The color of the cursor is     
  contained in CRSCOLOR. The cursor is xor'ed with what is      
  currently on the screen.                                      
  CURSOR TABLE FORMAT:                                          
    location-count-minus-1 C, loc1y C, loc1x C, loc1length C,   
    loc1width C, locn...                                        
ie.                                                             
    |<-- W -->|                                                 
    A---------B----------C-----D-------------------             
 L  |  THIS   |   IS     |  A  |  SAMPLE CURSOR   |             
    -----------------------------------------------             
CREATE SAMPTABLE                                                
  3 C, AY C, AX C, L C, W C, ...                                
( CURSOR -           CURSORSPACE BLD-CRS           AWK03-06-85) 
                                                                
: CURSORSPACE ( -- ablt \ set bltseg and return blt addr)       
  CURSEG @ BLTSEG ! 0 ;                                         
: BLD-CRS ( addr -- \ given cursor table addr and cursor )      
  ( location index in OCRS, plot the cursor)                    
 @COLOR >R                                                      
 CRSCOLOR @ !COLOR CURSORSPACE ABLT !                           
 XORMODE ON                                                     
 1+ OCRS @ 4 * + >R       ( -- crsaddr color)                   
 I     C@ YBLT !   I 1+  C@ XBLT !                              
 I 2+  C@ LBLT !  R> 3 + C@ WBLT ! BLT                          
 R> !COLOR ;                                                    
                                                                
                                                                
                                                                
( CURSOR -  SET-CRS                                AWK03-06-85) 
                                                                
: SET-CRS ( addr -- f \ given a cursor table addr and the new)  
  ( cursor location index in NCRS and the old cursor location)  
  ( in OCRS, plot a new, legal cursor and indicate if plotted)  
 NCRS @ OVER C@ 1+ 0 SWAP WITHIN                                
 IF NCRS @ OCRS @ = NOT                                         
    IF DUP BLD-CRS NCRS @ OCRS ! BLD-CRS 1                      
    ELSE DROP 0 THEN                                            
 ELSE C@ OCRS @ MIN 0 MAX DUP OCRS ! NCRS ! 0 THEN ;            
                                                                
                                                                
                                                                
                                                                
\ >ASCEND NEXT-NODE $!                                          
: $! ( $addr1 $addr2 -- )   OVER C@ 1+ CMOVE ;                  
                                                                
: SUBROOT ( -- )   CDEPTH (SRDEPTH) ! ;                         
                                                                
: SRDEPTH ( -- n )   CDEPTH (SRDEPTH) @ - ;                     
                                                                
HEAD: >ASCEND ( -- )                                            
T: BEGIN ?LAST SRDEPTH 0> AND WHILE ICLOSE REPEAT T;            
                                                                
: NEXT-NODE ( -- )                                              
 @INST-OFF OR                                                   
 IF IOPEN ELSE >ASCEND SRDEPTH 0>                               
   IF INEXT THEN                                                
 THEN ;                                                         
                                                                
( Nodes  <DESCEND PREV-NODE                      AWK 10/04/84 ) 
                                                                
\ HEAD: <DESCEND ( -- )                                         
\ T: BEGIN @INST-OFF OR WHILE IOPEN ILAST REPEAT T;             
                                                                
\ : PREV-NODE ( -- )                                            
\  ?FIRST SRDEPTH 0> AND                                        
\  IF ICLOSE ELSE SRDEPTH 0>                                    
\    IF IPREV THEN <DESCEND                                     
\  THEN ;                                                       
                                                                
                                                                
                                                                
( IT-OV - IFIELDS, AFIELDS                             10-1-85) 
                                                                
  0 17  2 IFIELD INST-VAL    68   4 3 AFIELD SHAPE              
  0 19  2 IFIELD INST-DATE   68 146 3 AFIELD RESEMBLES          
 11 0  16 AFIELD BOX-NAME                                       
 20 52 15 IFIELD %NAME                                          
 27 0  16 AFIELD ORIG-NAME                                      
 40 0  16 AFIELD SPEC-NAME                                      
 43 0  16 AFIELD BD-NAME                                        
 26 0  16 AFIELD ELEM-NAME                                      
 26 16  2 AFIELD ELEM-VAL                                       
 28 0  24 AFIELD ART-NAME                                       
 28 27  2 AFIELD ART-VAL                                        
 28 25  2 AFIELD ART-VOL                                        
 48 11  1 IFIELD PHR-CNT                                        
 48 12 254 IFIELD PHRASE                                        
                                                                
                                                                
( $ - U>$                                             10-1-85)  
                                                                
: U>$ ( u -- adr u \ convert single)                            
  ( length number to string)                                    
  0 <# #S #> ;                                                  
                                                                
                                                                
\ <CTVERSIONERROR> PUSH.OVT POP.OVT <CTASKMOUNT>                
                                                                
HEAD: PUSH.OVT T: 11 0 DO I OVT @ LOOP T;                       
HEAD: POP.OVT T: 0 10 DO I OVT ! -1 +LOOP T;                    
                                                                
: <CTVERSIONERROR> ( addr cnt -- )                              
  >R >R PUSH.OVT R> R>                                          
  CTINIT <VERSIONERROR>                                         
  POP.OVT ;                                                     
                                                                
: <CTASKMOUNT> ( -- )                                           
  PUSH.OVT CTINIT <ASKMOUNT> POP.OVT ;                          
                                                                
                                                                
( Text Instances for Window & Scroll             10/09/84 AWK ) 
                                                                
                                                                
FILE: SCROLL-TEXT 11  3 IFIELD TEXT-CONT                        
FILE: SCROLL-TEXT 14  3 IFIELD TEXT-INST                        
FILE: SCROLL-TEXT 17 38 IFIELD TEXT-TEXT                        
                                                                
: TEXT>PAD ( -- )                                               
 TEXT-TEXT PAD 1+ 38 CMOVE 38 PAD C! ;                          
                                                                
                                                                
( Text Output from misc.cmp to speed up msg display AWK 7/14/86)
                                                                
: CMESS ( line# len -- )                                        
 >R >R @CRS R> R> CTINIT                                        
 2* 80 SWAP - xBLT ! 23 SWAP 6 * - yBLT ! ;                     
                                                                
\ set-up for centered message of length len; !CRS must follow   
\ message type routine!                                         
                                                                
: X0MESS ( line# color -- ) 23 ROT 6 * - 38 ROT ROT 2           
 CONTEXT-ID# @ 5 < IF 4 MAX THEN POS.PXT ;                      
\ erase textline using specified color                          
                                                                
: 0MESS ( line# -- ) BLACK X0MESS ;                             
\ erase textline with black                                     
                                                                
                                                                
\ ruler test word                                               
exit                                                            
head: accumo ( d -- d )                                         
\ Accumlate length of current object into double # on stack.    
t: ibfr @ 3 - 0 d+ t;                                           
                                                                
: ruler ( iaddr -- d )                                          
\ Measure the length of the object on the stack and it's        
\ offspring.                                                    
  >c+s null                                                     
  ' accumo 'map !   ' ?first '?exit !  ' inext 'travers !       
  map>leaf iclose ;                                             
                                                                
                                                                
\ TRAP BAD ES REGISTER                                          
EXIT                                                            
CODE: [?ESBAD] ( -- es ds 1 OR 0 )                              
  0 ES SSG  1 DS SSG  1 0 SUB                                   
  0= IF 0 0 XOR ELSE ES PUSHS DS PUSHS 1 # 0 MOV THEN           
  0 PUSH NEXT                                                   
                                                                
HEAD: ?ESBAD                                                    
\ Do ES and DS registers conflict?                              
T: [?ESBAD] IF " DS,ES:" .TTY . . 500 MS THEN T;                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( Extended -trailing: -XTRAILING                  AWK 11/21/85 )
                                                                
ASCII . C: XTRAIL                                               
                                                                
: -XTRAILING ( addr cnt b -- addr' cnt' )                       
 ' XTRAIL ! ' XTRAIL CFA ' -TRAILING 14 + !                     
 -TRAILING                                                      
 ' BL CFA ' -TRAILING 14 + ! ;                                  
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( Executer for Communications and Combat          AWK 10/22/85 )
                                                                
: CEX+WAX ( -- )                                                
 'CEX+ @EXECUTE 'WAX @EXECUTE ;                                 
                                                                
                                                                
                                                                
\ This is a double external event called during encounters      
\ see !'EXT in hypermsg.cmp                                     
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( TASKS - ?FLARE ?OUTOFTIME                             6/03/86)
                                                                
HEAD: ?FLARE ( -- \ check for star flaring and execute)         
T: STARDATE @ (FLARE) @ = ?WIN @ 0= AND                         
   IF 'FLARE @EXECUTE THEN T;  ' NOP 'FLARE !                   
                                                                
EXIT                                                            
HEAD: ?OUTOFTIME ( -- \ if time expired end game)               
T: #HRS 3600     ( #secs --)                                    
   REAL-MS/STAR-HR 2@ 1000 U/MOD SWAP DROP                      
   */ ( 24) 48 /       ( end-stardate --)                       
   STARDATE @ < #HRS 0> AND                                     
   IF CTINIT " TIME'S UP." .TTY                                 
      KEY DROP BYE THEN T;                                      
                                                                
\ ?OUTOFTIME WORKS ONLY WHEN   #HRS   IS 0>                     
( TASKS - EXTERNAL-EVENTS  VEHICLE-REPAIR             12-18-84) 
                                                                
HEAD: EXTERNAL-EVENTS ( -- \ execute current external event )   
T:  ( simulation; ie. star flaring, alien behavior, alien )     
  ( communication etc.)                                         
  'EXTERNAL-EVENTS @EXECUTE T;                                  
                                                                
HEAD: VEHICLE-REPAIR ( -- \ vehicle repair over time)           
T:  'REPAIR @EXECUTE T;                                         
                                                                
                                                                
HEAD: ?VEHICLE-CYCLE ( -- t \ is it time to simulate vehicle?)  
T: 'VEHICLE-CYCLE @EXECUTE T;                                   
                                                                
                                                                
                                                                
( TASKS - POST-VEHICLE-STATUS  VEHICLE-SIMULATION     12-18-84) 
                                                                
HEAD: POST-VEHICLE-STATUS ( -- \ use current vehicle status )   
T:  ( display routine)                                          
  '.VEHICLE-STATUS @EXECUTE T;                                  
                                                                
HEAD: VEHICLE-SIMULATION ( -- \ execute vehicle simulation )    
T:  ( functions.)                                               
  ?VEHICLE-CYCLE                                                
  IF VEHICLE-REPAIR                                             
     POST-VEHICLE-STATUS                                        
  THEN T;                                                       
                                                                
                                                                
                                                                
                                                                
( TASKS - MEDICAL-TREATMENT  POST-VITAL-SIGNS         12-18-84) 
                                                                
HEAD: MEDICAL-TREATMENT                                         
T:  ( -- \ crew medical treatment over time)                    
  'TREATMENT @EXECUTE T;                                        
                                                                
HEAD: POST-VITAL-SIGNS                                          
T:  ( -- \ use current vital sign display )                     
  ( routine to show crew vital signs)                           
  '.VITAL-SIGNS @EXECUTE T;                                     
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
( TASKS - CREW-LIFE-SIMULATION                        12-18-84) 
                                                                
HEAD: ?CREW-CYCLE                                               
T: ( -- t \ is it time to simulate the crew live?)              
  'CREW-CYCLE @EXECUTE T;                                       
                                                                
HEAD: CREW-LIFE-SIMULATION                                      
T:  ( -- \ execute crew life simulation )                       
  ( functions)                                                  
  ?CREW-CYCLE                                                   
  IF MEDICAL-TREATMENT                                          
     POST-VITAL-SIGNS                                           
  THEN T;                                                       
                                                                
                                                                
                                                                
( TASKS - ?NEW-HOUR POST-NEW-DATE                      1-03-86) 
                                                                
: ?NEW-HOUR                                                     
 ( -- t \ time to increment star-hr counter check)              
  TIME D@ LAST-UPDATE D@ D- DABS REAL-MS/STAR-HR D@ D> ;        
                                                                
HEAD: POST-NEW-DATE                                             
T:  ( -- \ use current date display routine to )                
  ( show the date)                                              
  '.DATE @EXECUTE T;                                            
                                                                
                                                                
                                                                
                                                                
                                                                
                                                                
\ TASKS - PASS-TIME                                             
HEAD: PASS-TIME ( -- \ stardate update)                         
T:  ?NEW-HOUR                                                   
  IF TIME D@ LAST-UPDATE D!                                     
     ?SECURE @ ?DUP                                             
       IF STARDATE @ < CONTEXT-ID# @ 2 4 WITHIN AND             
         IF 'STP @ MODULE THEN                                  
       THEN                                                     
     STAR-HR @ 23 =                                             
     IF 1 STARDATE +! ?FLARE                                    
        STAR-HR OFF                                             
     ELSE 1 STAR-HR +!                                          
     THEN POST-NEW-DATE ?SUP @                                  
     IF 'ENERGY @EXECUTE THEN                                   
\     ?badindex \ debug: look for array damage                  
  THEN T;                                                       
( TASKS - PARALLEL-TASK                               12-18-84) 
                                                                
: PARALLEL-TASKS                                                
  ( -- \ entry point for execution of all )                     
  ( parallel tasks that can occur during the game.)             
  TIME-PASSING @                                                
  IF PASS-TIME                                                  
     CREW-LIFE-SIMULATION                                       
     VEHICLE-SIMULATION                                         
     EXTERNAL-EVENTS                                            
  THEN ;                                                        
                                                                
                                                                
                                                                
                                                                
                                                                
( TASKS - PUSH-TASKS POP-TASKS KEY-CASE               12-18-84) 
                                                                
HEAD: PUSH-TASKS                                                
T:  ( -- \ push the current tasks onto the vector)              
  ( stack)                                                      
  'CLEANUP @ >V    'KEY-CASE @ >V T;                            
                                                                
HEAD: POP-TASKS                                                 
T:  ( -- \ restore previous tasks from the vector)              
  ( stack)                                                      
  V> 'KEY-CASE !   V> 'CLEANUP ! T;                             
                                                                
HEAD: KEY-CASE                                                  
T:  ( key -- \ perform the task that is bound to the)           
  ( key code on the stack)                                      
  'KEY-CASE @EXECUTE T;                                         
( TASKS - DOTASKS                                      4/14/86) 
: DOTASKS ( 'cleanup  'key-case 'init -- \ execute a )          
 ( initialization routine and perform key triggered )           
 ( tasks and "parallel" tasks until task active flag)           
 ( is turned off at which time a cleanup task is executed.)     
 PUSH-TASKS EXECUTE                 ( execute initialization)   
 'KEY-CASE !   'CLEANUP ! 1 ( task active flag )                
 BEGIN ?TERMINAL FORCEKEY @ OR                                  
   IF 'KEY KEY-CASE TIME D@ KEYTIME D! ELSE SKEY OFF LKEY OFF   
   THEN \ trace @ 16 and                                        
\   if 20 0 position >0font .s 79 ." =S" col @ - spaces         
\                           .c 79 ." =C" col @ - spaces then    
   TIME D@ KEYTIME D@ D- 1000. D> FORCEPTASK @ OR               
   IF PARALLEL-TASKS THEN                                       
 ?DUP 0= UNTIL 'CLEANUP @EXECUTE pop-tasks ;                    
                                                                
\ xor a name with 127 to hide it                  ( rfg28apr86) 
\ exit **** add after debugging words removed                   
: xor! \ pfa --- | xors a name, is reversible                   
  dup nfa 1+ swap 2 - swap \ characters to flip                 
  2dup - 1 >               \ don't change null, !  etc.         
   if  do i 127 toggle 1 /loop                                  
   else 2drop                                                   
   then ;                                                       
                                                                
EXIT                                                            
some 'equates' after HEAD! is performed                         
7:>;^ is HEAD! \ to reverse operation, i.e., get back list      
(0-;, is WORDS                                                  
some words can't be found, even given their xor'd version       
because of the hashing. HEAD! was chosen as a name because it   
happens to hash to the same link chain.                         
\ (vlist) lookalike                               ( rfg28apr86) 
\ exit **** add after debugging words removed                   
                                                                
: head! \ voabulary pointed by CONTEXT or CURRENT               
  context @ 6 + pad 8 cmove                                     
 begin 0 0 pad dup 8 + swap \ for each of 4 chains              
  do dup i @ u<                                                 
     if 2drop i dup @ then \ this finds highest addr            
  2 /loop  over ?dup                                            
     if over 2- @ swap ! then                                   
  swap drop ?dup                                                
 while pfa xor! \ ?terminal if quit then                        
 repeat                                                         
 nodrives " starflt.com" >tib sysgen bye ;                      
                                                                
                                                                
( KERNEL - BOOT-HOOK set, dispose                      2/17/86 )
\ head: .load-voc ( -- )                                        
\  t: context-id# @ 1 5 within                                  
\   if tty-scroll 0 6 ctpos. ctinit current @ nfa id. then t;   
\  ' .load-voc ' 'ldov !                                        
                                                                
 ' >0FONT 'UNRAVEL !                                            
: STARTER  CONFIGURE-SYSTEM DOSPARM ;                           
' STARTER BOOT-HOOK !                                           
                                                                
 END-CX CXSP ! VCLR CR                                          
 ." Stack Pointers Reset."                                      
 DISPOSE                                                        
: dos ;                                                         
CR empty-buffers                                                
 ." TYPE 'NODRIVES SYSGEN KERNEL.COM' "    31 WIDTH !           
( KERNEL - LAST BLOCK   ESC-TRACE                      2/17/86 )
                                                                
