diff --git a/presentation.fs b/presentation.fs index be677ee..33f01b5 100755 --- a/presentation.fs +++ b/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 ) ; -: ( -- addr u0 ) ['] {h} , here 0 ; +: {h} ( addr -- addr ) cr s" " type 3 ptype-lenl ! cell+ ; \ header +: ( -- addr u0 ) ['] {h} , here 0 , 0 ; +: {/h} ( addr -- addr ) cr ; : ( addr len -- ) ['] {/h} , swap ! ; -:

( -- addr u0 ) ['] {p} , here 0 ; +: {p} ( addr -- addr ) cr ptype-reset cell+ ; \ paragraph +:

( -- addr u0 ) ['] {p} , here 0 , 0 ; +: {/p} ( addr -- addr ) cr ; :

( 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} ( addr -- addr ) 27 sgr ; : ( -- ) ['] {/i} , ; -: ( -- ) ['] {u} , ; -: ( -- ) ['] {/u} , ; +: {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 : ( -- ) ['] {fc} , , ; +: {/fc} ( addr -- addr ) 39 sgr ; : ( -- ) ['] {/fc} , ; +: {bc} ( addr -- addr ) dup @ 40 + sgr cell+ ; \ backgroundcolor : ( -- ) ['] {bc} , , ; +: {/bc} ( addr -- addr ) 49 sgr ; : ( -- ) ['] {/bc} , ; : {np} ( -- ) 0 sgr \ Alle Bildschirmeigenschaften zuruecksetzen - \ csi s" 2J" type \ Bildschirm leeren + \ csi type s\" 2J" type \ Bildschirm leeren ; : ( -- 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 - cell+ \ straddr addr - tuck @ \ addr straddr strlen - type \ addr + dup @ \ addr straddr + swap \ straddr addr + cell+ \ straddr 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 @@ : ( -- 0 addr0 !! '{np} ) 0 here ['] {np} , ; : ( 0 -- faddr laddr paddr 0 !! endaddr 0 0 0 0 <...addr> ) here \ 0 faddr - 0 , 0 , 0 , 0 , begin swap dup \ 0 addr0 faddr while , \ 0 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 s" Dies ist eine Testpresentation!" !!

- s" Eines Tages hatten wir (" !! s" Harald Steinlechner" !! - s" und" !! s" Denis Knauf" !! - s" die tolle Idee, eine Presentationssoftware zu schreiben" !! + s" Eines Tages hatten wir [" !! s" Harald Steinlechner" !! + s" und " !! s" Denis Knauf" !! + s" ] die tolle Idee, eine Presentationssoftware zu schreiben." !!

- s" Ergebnis:" !! + s" Ergebnis" !!

s" Das hier" !!

+ s" hallo" !!

s" Sieht doch garnicht so schlecht aus" !!