#! /usr/bin/gforth
\ here-allokation wird als fifo verwendet.
: copy ( addrdst addrsrc len -- addrdstend )
over ( dst src len src ) + swap ( dst end src )
do ( dst+ )
i ( dst+ src+ ) c@ ( dst+ chr )
over ( dst+ chr dst+ ) c! ( dst+ ) 1+
loop
;
: term-size form ;
: term-height ( -- i ) term-size drop ;
: term-width ( -- i ) term-size nip ;
: isnewline? ( c -- i ) dup 10 = swap 13 = or ;
: isspace? ( c -- i ) dup 9 = over 11 = or swap 32 = or ;
: anyspaces? ( c -- i ) dup isnewline? isspace? or ;
: clearwspace ( c -- c )
dup
case
9 of 32 endof
11 of 32 endof
13 of 10 endof
dup
endcase nip
;
variable ptype-lenl \ Wieviele Zeichen bereits in dieser Zeile geschrieben wurden
: ptype-word ( addrw addrc c -- addrc+1 )
-rot \ c addrw addrc
dup -rot over - type \ c addrc
swap emit 1+ \ addrc+1
;
: ptype-init ( addr len lenm lenl -- addre lenm lenl addrw addre addr )
{ addr len lenm lenl } addr len + lenm lenl addr addr len + addr
( 2over + \ addr len lenm lenl addre
rot swap tuck 2-rot \ addre lenm addr len lenl addre
2over drop rot swap \ addre lenm addr len addre lenl addr
dup -rot 2-rot \ addre lenm lenl addrw addr len addre addr
2nip \ addre lenm lenl addrw addre addr
)
;
: ptype-newline ( lenm lenl addrw addrc -- lenm 0 addrw )
\ s\" is a newline\n" type
10 ptype-word \ lenm lenl addrw=addrc+1
nip 0 swap \ lenm lenl=0 addrw
;
: ptype-space ( lenm lenl addrw addrc -- lenm lenl1 addrw )
\ s\" is a space\n" type
32 ptype-word \ lenm lenl addrw=addrc+1
swap 1+ swap \ lenm lenl+=1 addrw
;
: ptype-anychar ( lenm lenl addrw addrc -- lenm lenl addrw addrc )
\ s\" => any char\n" type
2over <=
\ .s cr
if
\ lenm lenl addrw addrc
rot tuck over swap - \ lenm addrw lenl addrc addrc-lenl \ m w l c c-l
2over drop >= \ lenm addrw lenl addrc addrc-lenl>=addrw
if \ Wort ist laenger als eine Zeile -> muss umgebrochen werden.
1- -rot 1- -rot 2dup - \ lenm lenl addrc-1 addrw addrc-1-addrw
type ." -" nip 1 swap dup \ lenm lenl addrw=addrc-1 addrc-1
else \ Word erst in der naechsten Zeile ausgeben.
nip 2dup - negate -rot \ lenm addrc-addrw addrw addrc
then
cr
then
rot 1+ -rot
\ .s cr
\ s\" <= any char\n" type
;
: ptype' ( addre lenm 0 addrw addre addr -- )
\ .s cr
\ addre ist fuer die schleife unwichtig
+do \ lenm lenl addrw
i dup c@ \ lenm lenl addrw addrc c
clearwspace
\ s\" loop>\n" type .s cr
case \ lenm lenl addrw addrc c
10 of ptype-newline endof
32 of ptype-space endof
drop ptype-anychar
endcase
\ .s cr
loop \ addre lenm lenl addrw
\ .s cr
over ptype-lenl !
nip nip tuck - type
;
: ptype ( addr len -- ) term-width ptype-lenl @ ptype-init ptype' ;
: ptype-reset ( -- ) 0 ptype-lenl ! ;
ptype-reset \ ptype-lenl sollte von Anfang an 0 sein
: escape ( -- addr len ) s\" \e" ;
: csi ( -- addr len ) s\" \e[" ;
: sgr ( u -- ) csi type 0 0 d.r 109 ( m ) emit ;
: beep 7 emit s" *beep* " type ;
\ Es folgen ein paar syntaktische Textauszeichnungen.
: {i} ( addr -- addr ) 7 sgr ;
: ( -- ) ['] {i} , ;
: {/i} ( addr -- addr ) 27 sgr ;
: ( -- ) ['] {/i} , ;
: {b} ( addr -- addr ) 1 sgr ; \ bold
: ( -- ) ['] {b} , ;
: {/b} ( addr -- addr ) 22 sgr ;
: ( -- ) ['] {/b} , ;
: {u} ( addr -- addr ) 4 sgr ; \ underline
: ( -- ) ['] {u} , ;
: {/u} ( addr -- addr ) 24 sgr ;
: ( -- ) ['] {/u} , ;
: {fc} ( addr -- addr ) dup @ 30 + sgr cell+ ; \ frontcolor
:
( -- ) ['] {br} , ;
\ Es folgen ein paar blockorientierte Kennzeichnungen.
: {h} ( addr -- addr )
cr
term-width over @ - 2 / \ addr width-twidth/2
dup ptype-lenl !
1 +do 32 emit loop
cell+
{b}
; \ header
:
( -- addr u0 ) ['] {p} , here 0 , 0 ; : {/p} ( addr -- addr ) cr ; :
( addr len -- ) ['] {/p} , swap ! ; : {li} ( addr -- addr ) s\" * " type 4 ptype-lenl ! cell+ ; :