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 fr Rasteroperationen 14 Um mit verschiedenen memMDFBs arbeiten zu k”nnen, mssen 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 zurckgegeben, mssen 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 zurckliefern, mssen 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