Screen 0 not modified     
 0 \\                  *** VDI -Funktionen ***            12aug86we
 1                                                                 
 2 Dieses File enth„lt alle VDI-Funktionen.                        
 3                                                                 
 4 Zur genaueren Beschreibung verweisen wir auf die Dokumentation  
 5 von Digital Research.                                           
 6 Dieser Hinweis ist nicht zynisch gemeint, aber wir sind nicht   
 7 in der Lage, das, was ATARI nicht zu leisten vermag, hier       
 8 nachzuholen. Mit geeigneten Unterlagen (wo gibts die ??) sollte 
 9 es aber m”glich sein, die Funktionen zu nutzen.                 
10 Beispiele findet man im Editor.                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 1 not modified     
 0 \ VDI Loadscreen                                       09sep86we
 1                                                                 
 2 Onlyforth                                                       
 3 \needs GEM     include gem\basics.scr                           
 4 Onlyforth                                                       
 5 \needs 2over   include double.scr                               
 6                                                                 
 7 Onlyforth  GEM also definitions                                 
 8                                                                 
 9   1 +load            cr .( Output Functions loaded) cr          
10   7 +load            cr .( Attribute Functions loaded) cr       
11 $0F +load            cr .( Raster Operations loaded) cr         
12 $15 +load            cr .( Input Functions loaded) cr           
13 $1B +load            cr .( Inquire Functions loaded) cr         
14 $1F +load            cr .( Escapes loaded) cr                   
15                                                                 
Screen 2 not modified     
 0 \ Output Functions Loadscreen                          27jan86we
 1                                                                 
 2 Onlyforth  GEM also definitions                                 
 3                                                                 
 4 01 05 +thru                                                     
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 3 not modified     
 0 \  pline pmarker gtext                              26f09sep86we
 1                                                                 
 2 : pline   ( x1 y1 x2 y2 ... xn yn count -- )                    
 3  >r  ptsin r@ 2* array!   6 r> 0 VDI ;                          
 4                                                                 
 5 : pmarker  ( x1 y1 x2 y2 ... xn yn count -- )                   
 6  >r  ptsin r@ 2* array!   7 r> 0 VDI ;                          
 7                                                                 
 8 | Code 1:2move  ( from to count -- )   SP )+ D0 move            
 9    SP )+ D6 move   D6 reg) A0 lea                               
10    SP )+ D6 move   D6 reg) A1 lea                               
11    D0 tst  0<> IF  1 D0 subq  D1 clr   D0 DO                    
12    .b A1 )+ D1 move  .w D1 A0 )+ move  LOOP  THEN  Next end-code
13                                                                 
14 : gtext    ( addr count x y -- )                                
15  ptsin 2 array!   >r intin r@ 1:2move  8 1 r> VDI ;             
Screen 4 not modified     
 0 \  fillarea contourfill                                01feb86we
 1                                                                 
 2 : fillarea  ( x1 y1 x2 y2 ... xn yn count -- )                  
 3  >r  ptsin r@ 2* array!   9 r> 0 VDI ;                          
 4                                                                 
 5 : contourfill  ( color x y -- )                                 
 6  ptsin 2 array!  intin !   &103 1 1 VDI ;                       
 7                                                                 
 8 : r_recfl    ( x1 y1 x2 y2 -- )                                 
 9  ptsin 4 array!  &114 2 0 VDI ;                                 
10                                                                 
11                                                                 
12 \\ cellarray                                                    
13                                                                 
14                                                                 
15                                                                 
Screen 5 not modified     
 0 \  GDP bar arc pie                                     03aug86we
 1                                                                 
 2 : GDP   ( #ptsin #intin functionno -- )                         
 3    function !   &11 -rot  VDI ;                                 
 4                                                                 
 5 : bar    ( x1 y1 x2 y2 -- )     ptsin 4 array!      2 0 1 GDP  ;
 6                                                                 
 7 : arc   ( startwinkel endwinkel x y radius -- )                 
 8   ptsin under  &12 + !   2 array!   intin 2 array!  4 2 2 GDP  ;
 9                                                                 
10 : pie   ( startwinkel endwinkel x y radius -- )                 
11   ptsin under  &12 + !   2 array!   intin 2 array!  4 2 3 GDP  ;
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 6 not modified     
 0 \  circle ellpie ellarc ellipse                        01feb86we
 1                                                                 
 2 : circle   ( x y radius -- )                                    
 3  ptsin under 8 + !   2 array!   3 0 4 GDP ;                     
 4                                                                 
 5 : ellarc   ( startwinkel endwinkel x y xradius yradius -- )     
 6  ptsin 4 array!   intin 2 array!   2 2 6 GDP ;                  
 7                                                                 
 8 : ellpie   ( startwinkel endwinkel x y xradius yradius -- )     
 9  ptsin 4 array!   intin 2 array!   2 2 7 GDP ;                  
10                                                                 
11 : ellipse   ( x y xradius yradius -- )                          
12  ptsin 4 array!   2 0 5 GDP ;                                   
13                                                                 
14                                                                 
15                                                                 
Screen 7 not modified     
 0 \  rbox rfbox justified                                01feb86we
 1                                                                 
 2 : rbox    ( x1 y1 x2 y2 -- )    ptsin 4 array!   2 0 8 GDP  ;   
 3                                                                 
 4 : rfbox   ( x1 y1 x2 y2 -- )    ptsin 4 array!   2 0 9 GDP  ;   
 5                                                                 
 6 : justified   ( string x y length wordspace charspace -- )      
 7  intin 2 array!   ptsin 3 array!   4 swap  count dup >r         
 8  bounds DO  I c@  over intin + !  2+  LOOP drop                 
 9  2 r> 2+ &10 GDP  ;                                             
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 8 not modified     
 0 \ Attribute Functions Loadscreen                       27jan86we
 1                                                                 
 2 Onlyforth  GEM also definitions                                 
 3                                                                 
 4 01 07 +thru                                                     
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 9 not modified     
 0 \  swr_mode Setmode                                    12aug86we
 1                                                                 
 2 : swr_mode   ( mode -- )        intin !   &32 0 1 VDI  ;        
 3                                                                 
 4                                                                 
 5 | : Setmode   ( n -- )          Create ,   Does>  @ swr_mode  ; 
 6                                                                 
 7 1 Setmode overwrite             2 Setmode transparent           
 8 3 Setmode exor                  4 Setmode revtransparent        
 9                                                                 
10                                                                 
11 \\                                                              
12 : scolor                                                        
13                                                                 
14                                                                 
15                                                                 
Screen 10 not modified     
 0 \  sl_type Settype sl_udsty                            31jan86we
 1                                                                 
 2 : sl_type   ( style -- )        intin !   &15 0 1 VDI ;         
 3                                                                 
 4 | : Settype   ( n -- )          Create ,    Does>  @ sl_type  ; 
 5                                                                 
 6 1 Settype solid                 2 Settype longdash              
 7 3 Settype dot                   4 Settype dashdot               
 8 5 Settype dash                  6 Settype dashdotdot            
 9 7 Settype userdef                                               
10                                                                 
11 : sl_udsty    ( pattern -- )     intin !   &113 0 1 VDI ;       
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 11 not modified     
 0 \  sl_width sl_color sl_ends                           01feb86we
 1                                                                 
 2 : sl_width   ( width -- )        ptsin !   &16 1 0 VDI  ;       
 3                                                                 
 4 : sl_color   ( color -- )        intin !   &17 0 1 VDI  ;       
 5                                                                 
 6 : sl_ends    ( begstyle endstyle -- )                           
 7  intin 2 array!   &108 0 2 VDI  ;                               
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 12 not modified     
 0 \  sm_type sm_height sm_color                          01feb86we
 1                                                                 
 2 : sm_type   ( symbol -- )       intin !   &18 0 1 VDI  ;        
 3                                                                 
 4 | : Setmtype   ( n -- )         Create ,   Does>  @ sm_type  ;  
 5                                                                 
 6 1 Setmtype point                2 Setmtype plus                 
 7 3 Setmtype asterisk             4 Setmtype square               
 8 5 Setmtype cross                6 Setmtype diamond              
 9                                                                 
10 : sm_height  ( height -- )                                      
11  0 ptsin 2!  &19 1 0 VDI  ;                                     
12                                                                 
13 : sm_color   ( color -- )       intin !   &20 0 1 VDI  ;        
14                                                                 
15                                                                 
Screen 13 not modified     
 0 \  st_height  st_point  st_rotation  st_color          01feb86we
 1                                                                 
 2 : st_height   ( height  -- )                                    
 3  0 ptsin 2!   &12 1 0 VDI  ;                                    
 4                                                                 
 5 : st_point       ( point -- )    intin !   &107 0 1 VDI  ;      
 6                                                                 
 7 : st_rotation    ( winkel -- )   intin !    &13 0 1 VDI  ;      
 8                                                                 
 9 : st_font        ( font -- )     intin !    &21 0 1 VDI  ;      
10                                                                 
11 : st_color       ( color -- )    intin !    &22 0 1 VDI  ;      
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 14 not modified     
 0 \  st_effects  st_alignement                           01feb86we
 1                                                                 
 2 : st_effects   ( effect -- )     intin !   &106 0 1 VDI  ;      
 3                                                                 
 4 : st_alignement   ( horin vertin -- )                           
 5  intin 2 array!   &39 0 2 VDI  ;                                
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 15 not modified     
 0 \  sf_interior sf_style sf_color sf_perimeter          31jan86we
 1                                                                 
 2 : sf_interior   ( style  -- )    intin !    &23 0 1 VDI  ;      
 3                                                                 
 4 : sf_style   ( styleindex -- )   intin !    &24 0 1 VDI  ;      
 5                                                                 
 6 : sf_color   ( color -- )        intin !    &25 0 1 VDI  ;      
 7                                                                 
 8 : sf_perimeter   ( pervis -- )   intin !   &104 0 1 VDI  ;      
 9                                                                 
10                                                                 
11 \\  sf_udpat                                                    
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 16 not modified     
 0 \ Raster Operations Loadscreen                         21nov86we
 1                                                                 
 2 Onlyforth  GEM also definitions                                 
 3                                                                 
 4 \needs malloc   include allocate.scr                            
 5                                                                 
 6                                                                 
 7 Create scrMFDB  0 , 0 ,                                         
 8                                                                 
 9 Variable >memMFDB                                               
10                                                                 
11 | $4711 Constant magic                                          
12                                                                 
13 1 5 +thru                                                       
14                                                                 
15                                                                 
Screen 17 not modified     
 0 \ ?allocate onscreen                                   11sep86we
 1                                                                 
 2 | Code ?allocate    >memMFDB R#) D6 move   D6 reg) A0 lea       
 3    .l A0 ) A0 move   .w magic A0 -) cmpi                        
 4         0= IF  Next  Assembler  THEN  ;c:                       
 5    $0.8004 malloc  swap even swap                               
 6    2dup magic -rot l!  2 extend  d+  >memMFDB @   2! ;          
 7                                                                 
 8 | Code onscreen                                                 
 9    scrMFDB # D6 move   D6 reg) A0 lea                           
10    .l A0 contrl &14 + R#) move   A0 contrl &18 + R#) move       
11    Next   end-code                                              
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 18 not modified     
 0 \ onscreen >screen screen>                             09sep86we
 1                                                                 
 2 | Code >screen                                                  
 3    >memMFDB R#) D6 move   D6 reg) A0 lea                        
 4    .l A0 contrl &14 + R#) move                                  
 5    .w scrMFDB # D6 move   D6 reg) A0 lea                        
 6    .l A0 contrl &18 + R#) move  ;c:  ?allocate ;                
 7                                                                 
 8 | Code screen>                                                  
 9    >memMFDB R#) D6 move   D6 reg) A0 lea                        
10    .l A0 contrl &18 + R#) move                                  
11    .w scrMFDB # D6 move   D6 reg) A0 lea                        
12    .l A0 contrl &14 + R#) move  ;c:  ?allocate ;                
13                                                                 
14                                                                 
15                                                                 
Screen 19 not modified     
 0 \ copyraster                                           23aug86we
 1                                                                 
 2 : copyopaque  ( Xfr Yfr width height Xto Yto mode --)           
 3  intin !  2over 2over d+  ptsin 8 +  4 array!                   
 4                 2over d+  ptsin      4 array!   &109 4 1 VDI ;  
 5                                                                 
 6 : scr>mem    ( addr_of_memMFDB -- )                             
 7    Create ,  Does>  @ >memMFDB !  screen>  2over 3 copyopaque ; 
 8                                                                 
 9 : mem>scr    ( addr_of_memMFDB -- )                             
10    Create ,  Does>  @ >memMFDB !  >screen  2over 3 copyopaque ; 
11                                                                 
12                                                                 
13 \\ scr>mem und mem>scr sind Defining-Words fr Rasteroperationen
14 Um mit verschiedenen memMDFBs arbeiten zu k”nnen, mssen jeweils
15 eigene Worte definiert werden. Beispiel: s. n„chster Screen     
Screen 20 not modified     
 0 \  r_trnfm get_pixel                                   09sep86we
 1                                                                 
 2 : scr>scr  ( Xfr Yfr width heigth Xto Yto --)                   
 3    onscreen 3 copyopaque ;                                      
 4                                                                 
 5 Create memMFDB1  7 , 0 , &640 , &400 , &40 , 0 , 1 ,            
 6                  0 , 0 , 0 ,                                    
 7                                                                 
 8 memMFDB1 scr>mem scr>mem1  ( Xleft Ytop Width Heigth -- )       
 9                                                                 
10 memMFDB1 mem>scr mem1>scr  ( Xleft Ytop Width Heigth -- )       
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 21 not modified     
 0 \  r_trnfm get_pixel                                   26feb86re
 1                                                                 
 2 : r_trnfm  ( -- )   >screen  &110 0 0 VDI ;                     
 3                                                                 
 4 : get_pixel  ( x y -- color flag )                              
 5  ptsin 2 array!  &105 1 0 VDI  intout 2@ swap ;                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 22 not modified     
 0 \ Input Functions Loadscreen                           12aug86we
 1                                                                 
 2 Onlyforth   GEM also definitions                                
 3                                                                 
 4  1  5 +thru                                                     
 5                                                                 
 6 \\                                                              
 7 Alle Input-Funktionen sollten von FORTH aus grunds„tzlich im    
 8 Sample-Mode arbeiten, da sonst kein Multitasking m”glich ist.   
 9 Daher sind nur die Sample-Funktionen implementiert. Die Opcodes 
10 der Request-Funktionen sind aber dieselben, sodaž durch Aufruf  
11 von  sin_mode  auch Request-Funktionen erreichbar sind.         
12 Zu Beginn eines Programms sollten ansonsten alle Device-Typen   
13 einmal mit  sin_mode  auf Sample geschaltet werden.             
14 Werden mehrere Werte zurckgegeben, mssen dies aus den diversen
15 Arrays geholt werden.                                           
Screen 23 not modified     
 0 \  sm_locater sm_valuator sm_choice                    12aug86we
 1                                                                 
 2 : sin_mode   ( devtype mode -- )  intin 2 array!  &33 0 2 VDI ; 
 3                                                                 
 4 : sm_locater   ( x y -- status )                                
 5  ptsin 2 array!  &28 1 0 VDI  #ptsout @  #addrout @ 2*  + ;     
 6 \ status: 0 -> no input         1 -> pos changed                
 7 \         2 -> key pressed      3 -> key pressed and pos changed
 8                                                                 
 9 : sm_valuator  ( val_in -- status )                             
10  intin !  &29 0 1 VDI  #addrout @ ;                             
11 \ status: 0 -> no action;1 -> valuator changed;2 -> key pressed 
12                                                                 
13 : sm_choice    ( -- status )                                    
14  &30 0 0 VDI  #addrout @ ;                                      
15 \ status: 0 -> no action        1 -> key pressed                
Screen 24 not modified     
 0 \  sm_string sc_form                                   01feb86we
 1                                                                 
 2 : sm_string   ( addr max_len echomode x y -- status )           
 3  ptsin 2 array!  intin 2 array!  &31 1 2 VDI                    
 4  #addrout @ over c!                                             
 5  #addrout @ 0 ?DO  intout I 2* + 1+ c@  over I + 1+ c!  LOOP    
 6  drop #addrout @ ;                                              
 7 \ status: 0 -> function aborted  n -> count of string           
 8 \ string wird als counted string bei addr abgelegt              
 9                                                                 
10 : sc_form   ( addr -- )                                         
11  intin &74 cmove  &111 0 &37 VDI  ;                             
12 \ addr is the adress of a data structure.                       
13 \ See description in VDI-Manual.                                
14                                                                 
15                                                                 
Screen 25 not modified     
 0 \  ex_time show_c hide_c                               02nov86we
 1                                                                 
 2 | : exchange_vecs    ( pusrcode functionno -- long_psavcode )   
 3      swap >absaddr contrl &14 + 2!    0 0 VDI                   
 4      contrl &18 + 2@  ;                                         
 5                                                                 
 6 : ex_time   ( tim_addr -- long_otim_addr )                      
 7    &118 exchange_vecs ;                                         
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 26 not modified     
 0 \  q_mouse ex_butv ex_motv ex_curv                     09sep86we
 1                                                                 
 2 : q_mouse   ( -- x y status )                                   
 3    &124 0 0 VDI  ptsout 2@  intout @ ;                          
 4                                                                 
 5 : ex_butv   ( pusrcode -- long_psavcode )                       
 6    &125 exchange_vecs ;                                         
 7                                                                 
 8 : ex_motv   ( pusrcode -- long_psavcode )                       
 9    &126 exchange_vecs ;                                         
10                                                                 
11 : ex_curv   ( pusrcode -- long_psavcode )                       
12    &127 exchange_vecs ;                                         
13                                                                 
14                                                                 
15                                                                 
Screen 27 not modified     
 0 \  q_key_s                                             31jan86we
 1                                                                 
 2 : q_key_s   ( -- status )                                       
 3  &128 0 0 VDI  intout @ ;                                       
 4 \ status: Bit 0 -> Right Shift Key   Bit 1 -> Left Shift Key    
 5 \         Bit 2 -> Control Key       Bit 3 -> Alt Key           
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 28 not modified     
 0 \ Inquire Functions Loadscreen                         31jan86we
 1                                                                 
 2 Onlyforth  GEM also definitions                                 
 3                                                                 
 4 01 03 +thru                                                     
 5                                                                 
 6 \\                                                              
 7 Die Werte, die die Inquire-Funktionen zurckliefern, mssen aus 
 8 den entsprechenden Arrays ausgelesen werden.                    
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 29 not modified     
 0 \  q_extnd q_color q_attributes                        01feb86we
 1                                                                 
 2 : q_extnd   ( info_flag -- )    intin !  &102 0 1 VDI ;         
 3                                                                 
 4 : q_color   ( color_index info_flag )                           
 5  intin 2 array!  &26 0 2 VDI  ;                                 
 6                                                                 
 7                                                                 
 8 | : q_attributes  ( n -- )      0 0 VDI ;                       
 9                                                                 
10 : ql_attributes   ( -- )        &35 q_attributes ;              
11 : qm_attributes   ( -- )        &36 q_attributes ;              
12 : qf_attributes   ( -- )        &37 q_attributes ;              
13 : qt_attributes   ( -- )        &38 q_attributes ;              
14                                                                 
15                                                                 
Screen 30 not modified     
 0 \  qt_extent qt_width qt_name                          31jan86we
 1                                                                 
 2 : qt_extent   ( string -- )                                     
 3  0 swap   count dup >r  bounds                                  
 4     DO  I c@  over intin + !  2+  LOOP drop                     
 5  &116 0 r> VDI ;                                                
 6                                                                 
 7 : qt_width   ( char -- status )                                 
 8  intin !  &117 0 1 VDI  intout @ ;                              
 9 \ status: -1 -> char invalid    n -> ADE-Value of char          
10                                                                 
11 : qt_name   ( element_num -- )                                  
12  intin !  &130 0 1 VDI ;                                        
13                                                                 
14                                                                 
15                                                                 
Screen 31 not modified     
 0 \  q_cellarray qin_mode qt_fontinfo                    01feb86we
 1                                                                 
 2 : q_cellarray   ( cols rows x1 y1 x2 y2 -- )                    
 3  ptsin 4 array!  contrl &14 + 2 array!  &27 2 0 VDI ;           
 4                                                                 
 5 : qin_mode   ( dev_type -- mode )                               
 6  intin !  &115 0 1 VDI  intout @ ;                              
 7                                                                 
 8 : qt_fontinfo   ( -- )          &131 0 0 VDI ;                  
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 32 not modified     
 0 \ Escapes Loadscreen                                   31jan86we
 1                                                                 
 2 Onlyforth  GEM also definitions                                 
 3                                                                 
 4 01 07 +thru                                                     
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 33 not modified     
 0 \  ESC normal_ESC                                      31jan86we
 1                                                                 
 2 | : ESC   ( #intin #ptsin functionno -- )                       
 3    function !  5 -rot VDI ;                                     
 4                                                                 
 5 | : normal_ESC   ( functionno -- )                              
 6  0 0 rot ESC ;                                                  
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 34 not modified     
 0 \  q_chcells exit_cur enter_cur cur_primitives         31jan86we
 1                                                                 
 2 : q_chcells   ( -- rows cols )  1 normal_ESC  intout 2@ ;       
 3                                                                 
 4 : exit_cur    ( -- )            2 normal_ESC ;                  
 5 : enter_cur   ( -- )            3 normal_ESC ;                  
 6                                                                 
 7 : curup       ( -- )            4 normal_ESC ;                  
 8 : curdown     ( -- )            5 normal_ESC ;                  
 9 : curright    ( -- )            6 normal_ESC ;                  
10 : curleft     ( -- )            7 normal_ESC ;                  
11 : curhome     ( -- )            8 normal_ESC ;                  
12                                                                 
13 : eeos        ( -- )            9 normal_ESC ;                  
14 : eeol        ( -- )          &10 normal_ESC ;                  
15                                                                 
Screen 35 not modified     
 0 \  s_curaddress curtext rvon rvoff                  26feb86we/re
 1                                                                 
 2 : s_curaddress   ( row col -- )                                 
 3  intin 2 array!  0 2 &11 ESC ;                                  
 4                                                                 
 5 : curtext  ( addr count -- )                                    
 6  >r  intin r@  1:2move  0 r> &12 ESC ;                          
 7                                                                 
 8 : rvon    ( -- )                &13 normal_ESC ;                
 9                                                                 
10 : rvoff   ( -- )                &14 normal_ESC ;                
11                                                                 
12 : q_curaddress   ( -- row col )                                 
13  &15 normal_ESC  intout 2@ ;                                    
14                                                                 
15                                                                 
Screen 36 not modified     
 0 \  q_tabstatus hardcopy dspcur rmcur form_adv          01feb86we
 1                                                                 
 2 : q_tabstatus   ( -- status )   &16 normal_ESC  intout @ ;      
 3                                                                 
 4 : hardcopy      ( -- )          &17 normal_ESC  ;               
 5                                                                 
 6 : dspcur        ( x y -- )      ptsin 2 array!  1 0 &18 ESC  ;  
 7                                                                 
 8 : rmcur         ( -- )          &19 normal_ESC  ;               
 9                                                                 
10 : form_adv      ( -- )          &20 normal_ESC  ;               
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 37 not modified     
 0 \  output_window clear_disp_list bit_image s_palette   01feb86we
 1                                                                 
 2 : output_window    ( x1 y1 x2 y2 -- )                           
 3  ptsin 4 array!  2 0 &21 ESC ;                                  
 4                                                                 
 5 : clear_disp_list  ( -- )       &22 normal_ESC  ;               
 6                                                                 
 7 : bit_image   ( string aspect scaling num_pts x1 y1 x2 y2 -- )  
 8  ptsin 4 array!  >r  intin 2 array!  4 swap  count dup >r       
 9  bounds DO  I c@  over intin + !  2+  LOOP drop                 
10  r>  r> 2+  &23  VDI ;                                          
11                                                                 
12 : s_palette   ( palette -- selected )                           
13  intin !  0 1 &60 ESC  intout @ ;                               
14                                                                 
15                                                                 
Screen 38 not modified     
 0 \  s_palette qp_films qp_state sp_state sp_save etc.   31jan86we
 1                                                                 
 2 : qp_films   ( -- )             &91 normal_ESC  ;               
 3 : qp_state   ( -- )             &92 normal_ESC  ;               
 4                                                                 
 5 : sp_state   ( addr -- )                                        
 6  intin &40 cmove  0 &20 &93 ESC  ;                              
 7 \ adr is the adress of a data structure                         
 8                                                                 
 9 : sp_save    ( -- )             &94 normal_ESC  ;               
10                                                                 
11 : sp_message   ( -- )           &95 normal_ESC  ;               
12                                                                 
13 : qp_error     ( -- )           &96 normal_ESC  ;               
14                                                                 
15                                                                 
Screen 39 not modified     
 0 \  meta_extents write_meta m_filename                  31jan86we
 1                                                                 
 2 : meta_extents   ( x1 y1 x2 y2 -- )                             
 3  ptsin 4 array!  2 0 &98 ESC ;                                  
 4                                                                 
 5 : write_meta     ( intin num_intin ptsin num_ptsin -- )         
 6  dup 2/ >r  ptsin swap cmove    dup >r  intin swap cmove        
 7  r> r> swap  &99 ESC ;                                          
 8                                                                 
 9 : m_filename     ( string -- )                                  
10  0 swap  count dup >r                                           
11  bounds DO  I c@  over intin + !  2+  LOOP  0 swap intin + !    
12  0 r> &100 ESC  ;                                               
13                                                                 
14                                                                 
15                                                                 
Screen 40 not modified     
 0 \ Demo fuer VDI                                        02feb86we
 1                                                                 
 2 Onlyforth  GEM also definitions                                 
 3                                                                 
 4 Create logo   ," volksFORTH 83"                                 
 5                                                                 
 6 : textdemo    clrwk  exor  1 st_font   1 st_color               
 7               &0 st_rotation     &13 st_effects                 
 8               80 0 DO  2 0 DO  J 4 / st_height                  
 9                   logo $80 20 J + 80 J 2* + 1 1 justified  LOOP 
10               4 +LOOP  logo $80 $A0 180 1 1 justified ;         
11                                                                 
12 : rahmen      0 0 sl_ends   10 sl_width                         
13               60 70  210 70  210 $C0  60 $C0  60 70  5 pline ;  
14                                                 -->             
15                                                                 
Screen 41 not modified     
 0 \ Kreis mit Mustern                                    02feb86we
 1                                                                 
 2 : torte                                                         
 3  2 sf_interior   1 sf_perimeter   1 sf_color                    
 4    9 sf_style      0 &450 &100 &300  &80 pie                    
 5  &07 sf_style  &450 &1000 &100 &300  &80 pie                    
 6  &12 sf_style &1000 &2400 &100 &300  &80 pie                    
 7  &19 sf_style &2400 &3600 &100 &300  &80 pie  ;                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14 : tdemo         grinit  page  textdemo rahmen torte  grexit ;   
15                                                                 
