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