ptype (mit einem bug)
This commit is contained in:
Denis Knauf
parent
9644964c7f
commit
9e78d1b5d0
169
presentation.fs
169
presentation.fs
|
|
@ -8,55 +8,143 @@
|
|||
loop
|
||||
;
|
||||
|
||||
: csi ( -- ) 27 emit 91 emit ;
|
||||
: sgr ( u -- ) csi 0 0 d.r 109 emit ;
|
||||
: 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_
|
||||
: ptype-lenl
|
||||
ptype-lenl_
|
||||
s\" \nptype-lenl = " type dup @ . cr
|
||||
;
|
||||
: 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 ) 80 ptype-lenl @ ptype-init ptype' ;
|
||||
: ptype-reset ( -- ) 0 ptype-lenl ! ;
|
||||
ptype-reset
|
||||
|
||||
: 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 blockorientierte Kennzeichnungen.
|
||||
: {h} ( addr -- addr ) cell+ ; \ header
|
||||
: {/h} ( addr -- addr ) ;
|
||||
: {p} ( addr -- addr ) cell+ ; \ paragraph
|
||||
: {/p} ( addr -- addr ) ;
|
||||
: <h> ( -- addr u0 ) ['] {h} , here 0 ;
|
||||
: {h} ( addr -- addr ) cr s" " type 3 ptype-lenl ! cell+ ; \ header
|
||||
: <h> ( -- addr u0 ) ['] {h} , here 0 , 0 ;
|
||||
: {/h} ( addr -- addr ) cr ;
|
||||
: </h> ( addr len -- ) ['] {/h} , swap ! ;
|
||||
: <p> ( -- addr u0 ) ['] {p} , here 0 ;
|
||||
: {p} ( addr -- addr ) cr ptype-reset cell+ ; \ paragraph
|
||||
: <p> ( -- addr u0 ) ['] {p} , here 0 , 0 ;
|
||||
: {/p} ( addr -- addr ) cr ;
|
||||
: </p> ( addr len -- ) ['] {/p} , swap ! ;
|
||||
\ Es folgen ein paar syntaktische Textauszeichnungen.
|
||||
: {i} ( addr -- addr ) 7 sgr ;
|
||||
: {/i} ( addr -- addr ) 27 sgr ;
|
||||
: {b} ( addr -- addr ) 1 sgr ; \ bold
|
||||
: {/b} ( addr -- addr ) 22 sgr ;
|
||||
: {u} ( addr -- addr ) 4 sgr ; \ underline
|
||||
: {/u} ( addr -- addr ) 24 sgr ;
|
||||
: {fc} ( addr -- addr ) dup @ 30 + sgr cell+ ; \ frontcolor
|
||||
: {/fc} ( addr -- addr ) 39 sgr ;
|
||||
: {bc} ( addr -- addr ) dup @ 40 + sgr cell+ ; \ backgroundcolor
|
||||
: {/bc} ( addr -- addr ) 49 sgr ;
|
||||
: <i> ( -- ) ['] {i} , ;
|
||||
: {/i} ( addr -- addr ) 27 sgr ;
|
||||
: </i> ( -- ) ['] {/i} , ;
|
||||
: <u> ( -- ) ['] {u} , ;
|
||||
: </u> ( -- ) ['] {/u} , ;
|
||||
: {b} ( addr -- addr ) 1 sgr ; \ bold
|
||||
: <b> ( -- ) ['] {b} , ;
|
||||
: {/b} ( addr -- addr ) 22 sgr ;
|
||||
: </b> ( -- ) ['] {/b} , ;
|
||||
: {u} ( addr -- addr ) 4 sgr ; \ underline
|
||||
: <u> ( -- ) ['] {u} , ;
|
||||
: {/u} ( addr -- addr ) 24 sgr ;
|
||||
: </u> ( -- ) ['] {/u} , ;
|
||||
: {fc} ( addr -- addr ) dup @ 30 + sgr cell+ ; \ frontcolor
|
||||
: <fc> ( -- ) ['] {fc} , , ;
|
||||
: {/fc} ( addr -- addr ) 39 sgr ;
|
||||
: </fc> ( -- ) ['] {/fc} , ;
|
||||
: {bc} ( addr -- addr ) dup @ 40 + sgr cell+ ; \ backgroundcolor
|
||||
: <bc> ( -- ) ['] {bc} , , ;
|
||||
: {/bc} ( addr -- addr ) 49 sgr ;
|
||||
: </bc> ( -- ) ['] {/bc} , ;
|
||||
|
||||
: {np} ( -- )
|
||||
0 sgr \ Alle Bildschirmeigenschaften zuruecksetzen
|
||||
\ csi s" 2J" type \ Bildschirm leeren
|
||||
\ csi type s\" 2J" type \ Bildschirm leeren
|
||||
;
|
||||
: <np> ( -- addr ) \ Wir legen jede Anfangsadresse einer Seite auf den Stack (Achtung, in umgekehrter Reihenfolge
|
||||
here ['] {np} ,
|
||||
;
|
||||
|
||||
: {!!} ( addr -- addr+2 )
|
||||
s" string-> " type .s newline type
|
||||
dup @ \ addr straddr
|
||||
swap \ straddr addr
|
||||
cell+ \ straddr addr
|
||||
tuck @ \ addr straddr strlen
|
||||
type \ addr
|
||||
tuck \ addr straddr addr
|
||||
@ \ addr straddr strlen
|
||||
ptype-init ptype' \ addr
|
||||
cell+
|
||||
s" string<- " type .s newline type
|
||||
;
|
||||
: !! ( len0 addr1 len1 -- len !! '{!!} addr1 len1 )
|
||||
['] {!!} ,
|
||||
|
|
@ -68,10 +156,9 @@
|
|||
: <presentation> ( -- 0 addr0 !! '{np} ) 0 here ['] {np} , ;
|
||||
: </presentation> ( 0 <addr...> -- faddr laddr paddr 0 !! endaddr 0 0 0 0 <...addr> )
|
||||
here \ 0 <addr...> faddr
|
||||
0 , 0 , 0 , 0 ,
|
||||
begin swap dup \ 0 <addr..> addr0 faddr
|
||||
while , \ 0 <addr..> faddr
|
||||
repeat .s
|
||||
repeat \ .s cr
|
||||
drop \ faddr
|
||||
here dup 0 \ faddr laddr paddr 0
|
||||
;
|
||||
|
|
@ -83,14 +170,14 @@
|
|||
\ laddr: letzte Seitenzeigeradresse (erste Presentationsseite)
|
||||
\ paddr: derzeitige Seitenzeigeradresse
|
||||
|
||||
: page_steps ( laddr paddr 0 [u] -- laddr naddr )
|
||||
: page_steps ( laddr paddr 0 [u] -- u )
|
||||
\ u muss ungleich 0 sein. falls u nicht vorhanden: 1
|
||||
dup 0= if 1 then \ laddr paddr 0 u
|
||||
nip cells - .s
|
||||
nip
|
||||
;
|
||||
: validpage? ( faddr laddr paddr -- faddr laddr paddr u )
|
||||
2dup < \ faddr laddr paddr u
|
||||
2over drop rot tuck >=
|
||||
2dup <= \ faddr laddr paddr u
|
||||
2over drop rot tuck >
|
||||
rot \ faddr laddr paddr u u
|
||||
if drop cell - -1 \ faddr laddr paddr-1 -1
|
||||
else if cell+ -1 \ faddr laddr paddr+1 -1
|
||||
|
|
@ -98,22 +185,18 @@
|
|||
then then
|
||||
;
|
||||
: showpage' ( paddr -- )
|
||||
dup cell - .s \ paddr paddr+cell
|
||||
dup cell - \ paddr paddr+cell
|
||||
@ swap @ \ naddr addr \ Seiteninhaltsadressen
|
||||
begin
|
||||
s" ++ " type 2dup . .
|
||||
2dup >
|
||||
dup . newline type
|
||||
begin 2dup >
|
||||
while
|
||||
dup cell+ swap \ naddr xtaddr xtaddr
|
||||
@ \ naddr xtaddr xt
|
||||
s" -> " type .s newline type
|
||||
execute \ verschiebt eventuell den Zeiger noch weiter, wenn es Parameter erwartet.
|
||||
s" <- " type .s newline type
|
||||
repeat
|
||||
2drop
|
||||
;
|
||||
: showpage ( faddr laddr paddr -- faddr laddr paddr 0 )
|
||||
cells -
|
||||
validpage?
|
||||
if beep then
|
||||
dup showpage' 0
|
||||
|
|
@ -123,7 +206,6 @@
|
|||
showpage
|
||||
;
|
||||
: g ( faddr laddr paddr 0 u -- faddr laddr paddr 0 )
|
||||
cells
|
||||
showpage
|
||||
;
|
||||
: p ( faddr laddr paddr 0 [u] -- faddr laddr paddr 0 )
|
||||
|
|
@ -131,18 +213,19 @@
|
|||
showpage
|
||||
;
|
||||
|
||||
here . newline type
|
||||
here
|
||||
<presentation>
|
||||
<h> s" Dies ist eine Testpresentation!" !! </h>
|
||||
<p>
|
||||
s" Eines Tages hatten wir (" !! <i> s" Harald Steinlechner" !! </i>
|
||||
s" und" !! <i> s" Denis Knauf" !! </i>
|
||||
s" die tolle Idee, eine Presentationssoftware zu schreiben" !!
|
||||
s" Eines Tages hatten wir [" !! <b> s" Harald Steinlechner" !! </b>
|
||||
s" und " !! <b> s" Denis Knauf" !! </b>
|
||||
s" ] die tolle Idee, eine Presentationssoftware zu schreiben." !!
|
||||
</p>
|
||||
<np>
|
||||
<h> s" Ergebnis:" !! </h>
|
||||
<h> s" Ergebnis" !! </h>
|
||||
<p> <b> s" Das hier" !! </b> </p>
|
||||
<np>
|
||||
<h> s" hallo" !! </h>
|
||||
<p> s" Sieht doch garnicht so schlecht aus" !! </p>
|
||||
</presentation>
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue