mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-10 05:29:31 +00:00
715 lines
44 KiB
Forth
715 lines
44 KiB
Forth
\ *** Block No. 0 Hexblock 0
|
||
\\ *** 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.
|
||
|
||
|
||
|
||
|
||
|
||
\ *** 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”nnen, m<EFBFBD>ssen jeweils
|
||
eigene Worte definiert werden. Beispiel: s. n„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„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<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 ;
|
||
|