mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-12-01 19:49:57 +00:00
715 lines
46 KiB
Plaintext
715 lines
46 KiB
Plaintext
|
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
|