From ddc601443045f3b59862b8f0aaf5e13b9a884f66 Mon Sep 17 00:00:00 2001
From: Denis Knauf <denis.knauf@gmail.com>
Date: Sun, 16 Jan 2011 17:23:45 +0100
Subject: [PATCH] scroll (sieht aber scheisse aus)

---
 presentation.fs   | 51 ++++++++++++++++++++++++++++++++++++++++++-----
 presentation.p.fs | 10 +++++-----
 2 files changed, 51 insertions(+), 10 deletions(-)

diff --git a/presentation.fs b/presentation.fs
index 8f2e7f1..aff8cd0 100755
--- a/presentation.fs
+++ b/presentation.fs
@@ -11,12 +11,44 @@
 \ 2-rot ist bei gforth anscheinend nicht definiert
 : 2-rot { a1 a2 b1 b2 c1 c2 } c1 c2 a1 a2 b1 b2 ;
 
+needs ansi.fs
+
+\ at-xy? war mal bestandteil von gforth:
+\ http://www.complang.tuwien.ac.at/cvsweb/cgi-bin/cvsweb/gforth/contrib/ansi.fs?rev=1.1;hideattic=0
+: read-cdnumber  ( c - n | read a numeric entry delimited by character c)
+	>r 0 begin
+		key dup r@ -
+		while
+		swap 10 * swap [char] 0 - +
+	repeat
+	r> 2drop
+;
+: at-xy?  ( -- x y | return the current cursor coordinates)
+	ESC[ ." 6n"
+	key drop key drop  \ <esc> [
+	[char] ; read-cdnumber [char] R read-cdnumber
+	1- swap 1-
+;
+
+: escape ( -- addr len ) s\" \e" ;
+: csi ( -- addr len ) s\" \e[" ;
+: sgr ( u -- ) csi type 0 .r [char] m emit ;
 : term-size form ;
 : term-height ( -- i ) term-size drop ;
 : term-width ( -- i ) term-size nip ;
+: cursor@ ( -- x y ) at-xy? ;
+: cursor! ( x y -- ) at-xy ;
+: cursorx@ ( -- x ) cursor@ drop ;
+: cursory@ ( -- y ) cursor@ nip ;
+: cursorx! ( x -- ) cursory@ cursor! ;
+: cursory! ( x -- ) cursorx@ swap cursor! ;
+: cursor^ ( i -- ) ESC[ 0 .r ." A" ;
+: cursor_ ( i -- ) ESC[ 0 .r ." B" ;
+: cursor> ( i -- ) ESC[ 0 .r ." C" ;
+: cursor< ( i -- ) ESC[ 0 .r ." D" ;
 
 : isnewline? ( c -- i ) dup 10 = swap 13 = or ;
-: isspace?   ( c -- i ) dup 9 = over 11 = or swap 32 = or ;
+: isspace?   ( c -- i ) dup  9 = over 11 = or swap 32 = or ;
 : anyspaces? ( c -- i ) dup isnewline? isspace? or ;
 
 : clearwspace ( c -- c )
@@ -39,6 +71,17 @@ variable typewriter-delay
 ;
 50 typewriter-delay !
 
+variable scroll-delay
+: scroll-type ( addr len -- )
+	term-width over - dup cursorx@ - swap cursorx!
+	-rot 2dup type scroll-delay @ ms dup 1 + cursor< 2dup type s"   " type
+	rot scroll-delay @ swap 1 +do
+		dup ms -rot dup 2 + cursor< 2dup type s"  " type rot
+	loop
+	2drop drop
+;
+1 scroll-delay !
+
 variable ptype-lenl \ Wieviele Zeichen bereits in dieser Zeile geschrieben wurden
 defer ptype-type
 ' type is ptype-type
@@ -61,7 +104,6 @@ defer ptype-type
 	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
 ;
@@ -99,9 +141,6 @@ defer ptype-type
 : 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
 	0 term-height 2 - at-xy
 	7 emit s" *beep* not" type
@@ -136,6 +175,8 @@ ptype-reset \ ptype-lenl sollte von Anfang an 0 sein
 : </animation> ( -- , xt-{/animation} ) ['] {/animation} , ;
 : <tw>  ( -- , xt xt ) ['] typewriter-type <animation> ;
 : </tw> ( -- , xt ) </animation> ;
+: <scroll>  ( -- , xt xt ) ['] scroll-type <animation> ;
+: </scroll> ( -- , xt ) </animation> ;
 \ Es folgen ein paar blockorientierte Kennzeichnungen.
 : {h}   ( addr , len -- addr )
 	cr
diff --git a/presentation.p.fs b/presentation.p.fs
index 42d6067..1a3a3f3 100644
--- a/presentation.p.fs
+++ b/presentation.p.fs
@@ -1,6 +1,6 @@
 
 \ Haeufig benutzte Textauszeichnungen:
-: <f> <b> 4 <fc> ;
+: <f> <b> Blue <fc> ;
 : </f> </fc> </b> ;
 
 : p4-1
@@ -45,11 +45,11 @@
 		!"  und " <b> <tw> !" Denis Knauf" </tw> </b>
 		!" ] die tolle Idee, eine Praesentationssoftware zu schreiben."
 	</p>
-	<en>
+	<p> <en>
 		<||> !" erstens"  </||> 
 		<||> !" zweitens" </||> 
 		<||> !" dann"     </||> 
-	</en>
+	</en> </p>
 <np>
 	<h> !" Ergebnis" </h>
 	<p> <b> !" Das hier" </b> </p>
@@ -65,8 +65,8 @@
 <np>
 	<h> !" Und Farben" </h>
 	<br>
-	<li> !" Hintergrundfarbe: " <f> s\" 3 <bc> !\" text\" </bc> " !! </f> !" : " 3 <bc> !\" text" </bc> </li>
-	<li> !" Vordergrundfarbe: " <f> s\" 5 <fc> !\" text\" </fc> " !! </f> !" : " 5 <fc> !\" text" </fc> </li>
+	<li> !" Hintergrundfarbe: " <f> s\" Yellow <bc> !\" text\" </bc> " !! </f> !" : " Yellow <bc> !\" text" </bc> </li>
+	<li> !" Vordergrundfarbe: " <f> s\" Brown <fc> !\" text\" </fc> " !! </f> !" : " Brown <fc> !\" text" </fc> </li>
 	<p> !" 8 Farben sind moeglich:" </p>
 	<p> farbendemo </p>
 </presentation>