VolksForth/sources/AtariST/GEM/VDI.FB.src

715 lines
46 KiB
Plaintext
Raw Normal View History

2020-06-20 16:59:55 +00:00
Screen 0 not modified
0 \\ *** VDI -Funktionen *** 12aug86we
1
2 Dieses File enth<74>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<64>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<64> 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<75>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<75>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