mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-26 17:49:18 +00:00
715 lines
44 KiB
Forth
715 lines
44 KiB
Forth
|
\ *** Block No. 0 Hexblock 0
|
|||
|
|
\\ *** VDI -Funktionen *** 12aug86we
|
|||
|
|
|
|||
|
|
Dieses File enth<EFBFBD>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<EFBFBD>glich sein, die Funktionen zu nutzen.
|
|||
|
|
Beispiele findet man im Editor.
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 1 Hexblock 1
|
|||
|
|
\ 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
|
|||
|
|
|
|||
|
|
\ *** Block No. 2 Hexblock 2
|
|||
|
|
\ Output Functions Loadscreen 27jan86we
|
|||
|
|
|
|||
|
|
Onlyforth GEM also definitions
|
|||
|
|
|
|||
|
|
01 05 +thru
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 3 Hexblock 3
|
|||
|
|
\ 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 ;
|
|||
|
|
\ *** Block No. 4 Hexblock 4
|
|||
|
|
\ 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
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 5 Hexblock 5
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 6 Hexblock 6
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 7 Hexblock 7
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 8 Hexblock 8
|
|||
|
|
\ Attribute Functions Loadscreen 27jan86we
|
|||
|
|
|
|||
|
|
Onlyforth GEM also definitions
|
|||
|
|
|
|||
|
|
01 07 +thru
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 9 Hexblock 9
|
|||
|
|
\ 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
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 10 Hexblock A
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 11 Hexblock B
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 12 Hexblock C
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 13 Hexblock D
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 14 Hexblock E
|
|||
|
|
\ st_effects st_alignement 01feb86we
|
|||
|
|
|
|||
|
|
: st_effects ( effect -- ) intin ! &106 0 1 VDI ;
|
|||
|
|
|
|||
|
|
: st_alignement ( horin vertin -- )
|
|||
|
|
intin 2 array! &39 0 2 VDI ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 15 Hexblock F
|
|||
|
|
\ 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
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 16 Hexblock 10
|
|||
|
|
\ 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
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 17 Hexblock 11
|
|||
|
|
\ ?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
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 18 Hexblock 12
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 19 Hexblock 13
|
|||
|
|
\ 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 Rasteroperationen
|
|||
|
|
Um mit verschiedenen memMDFBs arbeiten zu k<EFBFBD>nnen, m<EFBFBD>ssen jeweils
|
|||
|
|
eigene Worte definiert werden. Beispiel: s. n<EFBFBD>chster Screen
|
|||
|
|
\ *** Block No. 20 Hexblock 14
|
|||
|
|
\ 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 -- )
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 21 Hexblock 15
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 22 Hexblock 16
|
|||
|
|
\ Input Functions Loadscreen 12aug86we
|
|||
|
|
|
|||
|
|
Onlyforth GEM also definitions
|
|||
|
|
|
|||
|
|
1 5 +thru
|
|||
|
|
|
|||
|
|
\\
|
|||
|
|
Alle Input-Funktionen sollten von FORTH aus grunds<EFBFBD>tzlich im
|
|||
|
|
Sample-Mode arbeiten, da sonst kein Multitasking m<EFBFBD>glich ist.
|
|||
|
|
Daher sind nur die Sample-Funktionen implementiert. Die Opcodes
|
|||
|
|
der Request-Funktionen sind aber dieselben, soda<EFBFBD> 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<EFBFBD>ckgegeben, m<EFBFBD>ssen dies aus den diversen
|
|||
|
|
Arrays geholt werden.
|
|||
|
|
\ *** Block No. 23 Hexblock 17
|
|||
|
|
\ 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
|
|||
|
|
\ *** Block No. 24 Hexblock 18
|
|||
|
|
\ 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.
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 25 Hexblock 19
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 26 Hexblock 1A
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 27 Hexblock 1B
|
|||
|
|
\ 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
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 28 Hexblock 1C
|
|||
|
|
\ Inquire Functions Loadscreen 31jan86we
|
|||
|
|
|
|||
|
|
Onlyforth GEM also definitions
|
|||
|
|
|
|||
|
|
01 03 +thru
|
|||
|
|
|
|||
|
|
\\
|
|||
|
|
Die Werte, die die Inquire-Funktionen zur<EFBFBD>ckliefern, m<EFBFBD>ssen aus
|
|||
|
|
den entsprechenden Arrays ausgelesen werden.
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 29 Hexblock 1D
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 30 Hexblock 1E
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 31 Hexblock 1F
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 32 Hexblock 20
|
|||
|
|
\ Escapes Loadscreen 31jan86we
|
|||
|
|
|
|||
|
|
Onlyforth GEM also definitions
|
|||
|
|
|
|||
|
|
01 07 +thru
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 33 Hexblock 21
|
|||
|
|
\ ESC normal_ESC 31jan86we
|
|||
|
|
|
|||
|
|
| : ESC ( #intin #ptsin functionno -- )
|
|||
|
|
function ! 5 -rot VDI ;
|
|||
|
|
|
|||
|
|
| : normal_ESC ( functionno -- )
|
|||
|
|
0 0 rot ESC ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 34 Hexblock 22
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
\ *** Block No. 35 Hexblock 23
|
|||
|
|
\ 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@ ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 36 Hexblock 24
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 37 Hexblock 25
|
|||
|
|
\ 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 @ ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 38 Hexblock 26
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 39 Hexblock 27
|
|||
|
|
\ 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 ;
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
\ *** Block No. 40 Hexblock 28
|
|||
|
|
\ 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 ;
|
|||
|
|
-->
|
|||
|
|
|
|||
|
|
\ *** Block No. 41 Hexblock 29
|
|||
|
|
\ 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 ;
|
|||
|
|
|