Commit ec52ea5f authored by bp's avatar bp
Browse files

Added nested picture number stuff

git-svn-id: https://forth-ev.de/repos/bigforth@1716 3b8d8251-53f3-0310-8f3b-fd1cb8370982
parent 90a171f1
This diff is collapsed.
......@@ -5,7 +5,7 @@ Variable click# click# off
X" There have been no clicks yet" text-label new
dup F bind click-label
^ S[ 1 click# +!
click# @ 0 <# #S s" Number of clicks: " holds #>
click-label assign ]S X" Click me" button new
click# @ 0 <<# #s s" Number of clicks: " holds #>
click-label assign #>> ]S X" Click me" button new
&2 vabox new panel s" Clicks" assign show endwith ;
click-win
This diff is collapsed.
......@@ -239,7 +239,7 @@ stredit implements
IF [defined] filename [IF] filename >len scratch$ $+!
[ELSE] drop [THEN] THEN
S" Line # " scratch$ $+! base push decimal
line#@ 0 <# bl hold # # # #S #> scratch$ $+!
line#@ 0 <<# bl hold # # # #S #> scratch$ $+! #>>
update$ scratch$ $+! scratch$ $@ ;
: maketitle edifile @ 0= ?EXIT
title$ dpy get-dpy window with title! endwith
......
......@@ -108,7 +108,7 @@ scredit implements
: title$ ( -- addr u )
base push decimal
S" Scr # " scratch$ $!
scr# @ 0 <# bl hold # # #S #> scratch$ $+!
scr# @ 0 <<# bl hold # # #S #> scratch$ $+! #>>
scratch$ $@ ;
[ELSE]
: updated? ( -- f ) 'start 4- @ $14 + wx@ 0< ;
......@@ -117,7 +117,7 @@ scredit implements
: title$ ( -- addr u )
base push decimal
edifile @ filename >len scratch$ $!
S" Scr # " scratch$ $+! scr# @ 0 <# bl hold # # #S #> scratch$ $+!
S" Scr # " scratch$ $+! scr# @ 0 <<# bl hold # # #S #> scratch$ $+! #>>
update$ scratch$ $+!
scratch$ $@ ;
[THEN]
......
\ Etiketten drucken (zweispaltig) 01jan10pyCreate (name" $20 allot Create (film $20 allot \ Variable date dos dattime $4000000 / &80 + date ! forth : name" ascii " parse (name" place ; name" Frank Paysan" : film bl word count (film place ; film F9101AC \ F9101AC/36 : .archivnummer ( n -- ) base push decimal (film count 2dup type + 1- c@ 'D' = IF ." /img_" 0 <# # # # # #> type ." .jpg" ELSE ." /" 0 <# # # #> type THEN ; : tab 9 emit ; : .name (name" count type ; : .copyright ." Copyright (c) 20" base push decimal (film 2+ 2 type ." by" ; --> \ Init 17may09py include fileop.fb also fileop : init s" /dev/usblp0" r/w output-file +buffer #esc emit 'A emit 5 emit \ Halber Vorschub #esc emit 'D emit &16 emit 0 emit \ Tabulator #esc emit 'A emit 5 emit \ Halber Vorschub #esc emit 'S emit 0 emit \ Hochstellen #esc emit 'p emit 1 emit \ Proportionalschrift ; : fcr ( #cr emit ) cr ; --> \ Etiketten drucken (zweispaltig) 26may08py : .etikette ( #1 #2 -- ) init swap .copyright tab .copyright fcr .name tab .name fcr ." Stockmannstr. 14" tab ." Stockmannstr. 14" fcr ." 81477 Mnchen" tab ." 81477 Mnchen" fcr ." Archivnummer:" tab ." Archivnummer:" fcr .archivnummer tab .archivnummer fcr fcr fcr fcr fcr fcr fcr eot ; : .etiketten ( end start -- ) ?DO i i 1+ .etikette stop? ?LEAVE 2 +LOOP ; --> \ Etiketten drucken (Liste) 18apr89py: .elist ( n1 n2 n3 .. nx x -- ) >r r@ init 0 ?DO i' i - 1- pick 1 > IF i dup .etikette i' i - 1- >r r@ pick 2- r@ pin r> pick 0= negate ELSE i' i - 1- pick 0<> IF i' i - 1 = IF i 0 .etikette 1 ELSE 1 BEGIN i' i - over - pick 0= WHILE 1+ REPEAT i 2dup + .etikette i' i - over - >r r@ pick 1- r@ pin r@ 1+ pick 1- r> 1+ pin THEN ELSE 1 THEN THEN stop? IF drop leave THEN +LOOP r> 0 ?DO drop LOOP eot ;
\ No newline at end of file
\ Etiketten drucken (zweispaltig) 07aug10pyCreate (name" $20 allot Create (film $20 allot \ Variable date dos dattime $4000000 / &80 + date ! forth : name" ascii " parse (name" place ; name" Frank Paysan" : film bl word count (film place ; film F9101AC \ F9101AC/36 : .archivnummer ( n -- ) base push decimal (film count 2dup type + 1- c@ 'D' = IF ." /img_" 0 <<# # # # # #> type #>> ." .jpg" ELSE ." /" 0 <<# # # #> type #>> THEN ; : tab 9 emit ; : .name (name" count type ; : .copyright ." Copyright (c) 20" base push decimal (film 2+ 2 type ." by" ; --> \ Init 17may09py include fileop.fb also fileop : init s" /dev/usblp0" r/w output-file +buffer #esc emit 'A emit 5 emit \ Halber Vorschub #esc emit 'D emit &16 emit 0 emit \ Tabulator #esc emit 'A emit 5 emit \ Halber Vorschub #esc emit 'S emit 0 emit \ Hochstellen #esc emit 'p emit 1 emit \ Proportionalschrift ; : fcr ( #cr emit ) cr ; --> \ Etiketten drucken (zweispaltig) 26may08py : .etikette ( #1 #2 -- ) init swap .copyright tab .copyright fcr .name tab .name fcr ." Stockmannstr. 14" tab ." Stockmannstr. 14" fcr ." 81477 Mnchen" tab ." 81477 Mnchen" fcr ." Archivnummer:" tab ." Archivnummer:" fcr .archivnummer tab .archivnummer fcr fcr fcr fcr fcr fcr fcr eot ; : .etiketten ( end start -- ) ?DO i i 1+ .etikette stop? ?LEAVE 2 +LOOP ; --> \ Etiketten drucken (Liste) 18apr89py: .elist ( n1 n2 n3 .. nx x -- ) >r r@ init 0 ?DO i' i - 1- pick 1 > IF i dup .etikette i' i - 1- >r r@ pick 2- r@ pin r> pick 0= negate ELSE i' i - 1- pick 0<> IF i' i - 1 = IF i 0 .etikette 1 ELSE 1 BEGIN i' i - over - pick 0= WHILE 1+ REPEAT i 2dup + .etikette i' i - over - >r r@ pick 1- r@ pin r@ 1+ pick 1- r> 1+ pin THEN ELSE 1 THEN THEN stop? IF drop leave THEN +LOOP r> 0 ?DO drop LOOP eot ;
\ No newline at end of file
\ Etiketten drucken (zweispaltig) 30nov09pyCreate (name" $20 allot Create (film $20 allot \ Variable date dos dattime $4000000 / &80 + date ! forth : name" ascii " parse (name" place ; name" Frank Paysan" : film bl word count (film place ; film F0911AD \ F9101AC/36 : .archivnummer ( n -- ) base push decimal (film count 2dup type + 1- c@ 'D' = IF ." /img_" 0 <# # # # # #> type ." .jpg" ELSE ." /" 0 <# # # #> type THEN ; : tab 9 emit ; : .name (name" count type ; : .copyright ." Copyright (c) 20" base push decimal (film 2+ 2 type ." by" ; --> \ Init 30nov09py \needs fileop include fileop.fb also fileop : init s" /dev/usblp0" r/w output-file +buffer \ #esc emit 'A emit 5 emit \ Halber Vorschub #esc emit 'D emit &16 emit 0 emit \ Tabulator \ #esc emit 'A emit 5 emit \ Halber Vorschub \ #esc emit 'S emit 0 emit \ Hochstellen #esc emit 'p emit 1 emit \ Proportionalschrift ; : fcr ( #cr emit ) cr ; --> \ Etiketten drucken (zweispaltig) 01jan10py : leer 3 spaces ; : (.etikette ( #1 -- ) leer ." (c) " .name ." 20" (film 2+ 2 type fcr leer ." Stockmannstr. 14" fcr leer ." 81477 Mnchen" fcr leer ." Archivnummer:" fcr leer .archivnummer fcr 11 0 DO fcr LOOP ; : .etikette ( #1 -- ) init (.etikette eot ; : .etiketten ( end start -- ) init ?DO i (.etikette stop? ?LEAVE LOOP eot ; --> \ Etiketten drucken (Liste) 30nov09py : .elist ( n1 n2 n3 .. nx x -- ) >r r@ init 0 ?DO I' I - 1- pick (.etikette stop? ?LEAVE LOOP eot r> 0 ?DO drop LOOP ;
\ No newline at end of file
\ Etiketten drucken (zweispaltig) 07aug10pyCreate (name" $20 allot Create (film $20 allot \ Variable date dos dattime $4000000 / &80 + date ! forth : name" ascii " parse (name" place ; name" Frank Paysan" : film bl word count (film place ; film F0911AD \ F9101AC/36 : .archivnummer ( n -- ) base push decimal (film count 2dup type + 1- c@ 'D' = IF ." /img_" 0 <<# # # # # #> type #>> ." .jpg" ELSE ." /" 0 <<# # # #> type #>> THEN ; : tab 9 emit ; : .name (name" count type ; : .copyright ." Copyright (c) 20" base push decimal (film 2+ 2 type ." by" ; --> \ Init 30nov09py \needs fileop include fileop.fb also fileop : init s" /dev/usblp0" r/w output-file +buffer \ #esc emit 'A emit 5 emit \ Halber Vorschub #esc emit 'D emit &16 emit 0 emit \ Tabulator \ #esc emit 'A emit 5 emit \ Halber Vorschub \ #esc emit 'S emit 0 emit \ Hochstellen #esc emit 'p emit 1 emit \ Proportionalschrift ; : fcr ( #cr emit ) cr ; --> \ Etiketten drucken (zweispaltig) 01jan10py : leer 3 spaces ; : (.etikette ( #1 -- ) leer ." (c) " .name ." 20" (film 2+ 2 type fcr leer ." Stockmannstr. 14" fcr leer ." 81477 Mnchen" fcr leer ." Archivnummer:" fcr leer .archivnummer fcr 11 0 DO fcr LOOP ; : .etikette ( #1 -- ) init (.etikette eot ; : .etiketten ( end start -- ) init ?DO i (.etikette stop? ?LEAVE LOOP eot ; --> \ Etiketten drucken (Liste) 30nov09py : .elist ( n1 n2 n3 .. nx x -- ) >r r@ init 0 ?DO I' I - 1- pick (.etikette stop? ?LEAVE LOOP eot r> 0 ?DO drop LOOP ;
\ No newline at end of file
......@@ -2,7 +2,7 @@
: dumped ftab 8 cells + @ cell+ ;
| : 0.r 0 swap <# 0 ?DO # LOOP #> type ;
| : 0.r 0 swap <<# 0 ?DO # LOOP #> type #>> ;
| : .header ( -- ) 3 S" AXCXDXBXSPBPSIDI" bounds
DO spaces I 2 type 7 2 +LOOP drop ;
| : .regs ( -- ) dumped 8 cells +
......@@ -38,8 +38,8 @@
: in_which? ( addr -- len nfa count/false ) cell swap dup @
[ ' push 5 + @ ] ALiteral =
IF swap 3 * swap cell+ 2@ swap
0 <# #S drop bl hold #S
s" push " 1- FOR dup I + c@ hold NEXT drop #> EXIT THEN
0 <<# #S drop bl hold #s
s" push " 1- FOR dup I + c@ hold NEXT drop #> #>> EXIT THEN
@ context @ over noop in_voc?
dup IF nip count $1F and EXIT THEN drop voc-link
BEGIN @ dup WHILE 2dup 8 - swap in_voc? dup
......@@ -48,7 +48,7 @@
| : "name ( nfa count / 0 -- ) ?dup
IF $add S" " $add
ELSE 0 <# bl hold #S '$ hold #> $add THEN ;
ELSE 0 <<# bl hold #S '$ hold #> $add #>> THEN ;
: "back ( addr -- addr len ) base push hex dup off $sum !
S" Level: " $add backtrace 8 cells bounds
?DO I in_which? dup 0= IF I @ swap THEN "name
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
No preview for this file type
......@@ -464,7 +464,7 @@ struct{
cell hc_wavetable
} gsl_fft_precomputes
| create $buf 255 allot
| : 2str dup >r abs s>d <# #s r> sign #> $buf 0place ;
| : 2str dup >r abs s>d <<# #s r> sign #> $buf 0place #>> ;
| : s>hash ( n -- key ) 2str $buf hash ;
| : (cache-fft) ( n -- addr )
sizeof gsl_fft_precomputes allocate throw >r
......
......@@ -517,16 +517,16 @@ synonym VT[ noop-i
\ number input field 27apr98py
edit-action class number-action
public: cell var nbase
how: : ># ( d -- addr u ) base push nbase @ base ! tuck dabs
<# #S nbase @ $10 = IF '$' hold THEN
nbase @ %10 = IF '%' hold THEN rot sign #> ;
how: : #>text ( d -- addr u ) base push nbase @ base ! tuck dabs
<<# #s nbase @ $10 = IF '$' hold THEN
nbase @ %10 = IF '%' hold THEN rot sign #> #>> ;
: key ( key sh -- ) drop base push nbase @ base !
dup shift-keys? IF drop EXIT THEN dup find-key dup
IF cell+ @ caller send drop
ELSE drop dup digit? nip 0= ?EXIT
sp@ 1 edit with ins drop 1 c drop endwith
THEN stroke @ called send ;
: store ( d -- ) ># edit assign ;
: store ( d -- ) #>text edit assign ;
: fetch ( -- d ) edit get base push decimal s>number ;
: init ( o addr -- ) #10 nbase ! super init ;
class;
......@@ -852,9 +852,9 @@ public: method #>text \ early scalekey
\ new scaler 03dec06py
how: : #>text ( n -- addr u ) base push decimal
text/ @ m* tuck dabs <#
text/ @ m* tuck dabs <<#
text*/ @ 1 ?DO # I 9 * +LOOP
text*/ @ 1 > IF '.' hold THEN #S rot sign #> ;
text*/ @ 1 > IF '.' hold THEN #S rot sign #> #>> ;
: .text ( addr u x y c -- ) >r 2swap r>
fnt select fnt self fnt ' display dpy drawer ;
: get ( -- steps step pos ) super get 0 swap ;
......@@ -938,9 +938,9 @@ public: method #>text \ early scalekey
\ new scaler 08mar07py
how: : #>text ( n -- addr u ) base push decimal
text/ @ m* tuck dabs <#
text/ @ m* tuck dabs <<#
text*/ @ 1 ?DO # I 9 * +LOOP
text*/ @ 1 > IF '.' hold THEN #S rot sign #> ;
text*/ @ 1 > IF '.' hold THEN #S rot sign #> #>> ;
: .text ( addr u x y c -- ) >r 2swap r>
fnt select fnt self fnt ' display dpy drawer ;
: get ( -- steps step pos ) super get 0 swap ;
......
......@@ -826,7 +826,7 @@ how: \ 6 colors defocuscol !
: assign ( size time attr addr len -- ) base push
super assign attr ! time ! size ! ;
: !resized super !resized decimal
size @ 0 <# #S #> 0 textsize drop wsize !
size @ 0 <<# #s #> 0 textsize drop wsize ! #>>
S" 00may99" 0 textsize drop wdate !
S" 00:00:00" 0 textsize drop wtime ! ;
[defined] x11 [IF] : dir@ attr @ $C >> ; [THEN]
......@@ -846,8 +846,8 @@ how: \ 6 colors defocuscol !
w @ wdate @ - 6 - 0 p+
time @ >date 2over cc .text
m wtime @ + 0 p- time @ >time 2over cc .text
m wsize @ + 0 p- size @ 0 <# #S #>
2swap cc .text ;
m wsize @ + 0 p- size @ 0 <<# #s #>
2swap cc .text #>> ;
\ file widget 10apr04py
: hglue ( -- glue ) super hglue xM 3 *
......
......@@ -119,7 +119,7 @@ Variable list$
IF cr ." depends " over .id .list ELSE drop THEN
cr drop ;
: d.2 ( n -- ) base push decimal 0 <# # # '. hold #s #> type ;
: d.2 ( n -- ) base push decimal 0 <<# # # '. hold #s #> type #>> ;
: .resource ( addr -- ) base push decimal
cr ." resource " dup resource id $@ type space
......@@ -138,7 +138,7 @@ Variable list$
\ print globals 21apr01py
: .iso-date ( n char -- ) base push decimal >r
0 <# # # r@ hold # # r> hold #s #> type ;
0 <<# # # r@ hold # # r> hold #s #> type #>> ;
: .prefix ( addr -- ) global prefix $@ type ;
: .files ( addr n suffix n type n -- ) { suffix n1 typ n2 }
......
......@@ -107,7 +107,7 @@ s" foofoofoo" ?foos1
s// \( \d \d \) ` : \( \d \d \) ` : \( \d \d \)
\1 s>number drop 60 *
\2 s>number drop + 60 *
\3 s>number drop + 0 <# 's' hold #s #> //g ;
\3 s>number drop + 0 <<# 's' hold #s #> #>> //g ;
s" bla 12:34:56 fasel 00:01:57 blubber" hms>s
s" bla 45296s fasel 117s" str= 0= [IF] .( failed) [THEN]
......
......@@ -460,7 +460,7 @@ minos
Variable ?showpath ?showpath on
| : scr# ( -- addr len ) scr @ abs extend
<# #S s" klB" bounds DO I c@ hold LOOP #> ;
<<# #s s" klB" bounds DO I c@ hold LOOP #> #>> ;
: boxhandler ( addr -- ) tflush
dup count here count ?showpath @
......
\ inspired by Thinking Forth 31oct04py \ roman numbers 31oct04py Variable column# : symbol ( off -- ) column# @ + s" IVXLCDM " drop + c@ hold ; : oner ( -- ) 0 symbol ; : fiver ( -- ) 1 symbol ; : almost ( q -- ) 1+ symbol oner ; : oners ( n -- ) 0 ?DO oner LOOP ; : digit ( digit -- ) 5 /mod over 4 = IF almost drop ELSE swap oners IF fiver THEN THEN ; : #r ( digit -- digit' ) 10 /mod swap digit 2 column# +! ; : roman ( number -- ) column# off <# #r #r #r #r 0 #> type ;
\ No newline at end of file
\ inspired by Thinking Forth 31oct04py \ roman numbers 07aug10py Variable column# : symbol ( off -- ) column# @ + s" IVXLCDM " drop + c@ hold ; : oner ( -- ) 0 symbol ; : fiver ( -- ) 1 symbol ; : almost ( q -- ) 1+ symbol oner ; : oners ( n -- ) 0 ?DO oner LOOP ; : digit ( digit -- ) 5 /mod over 4 = IF almost drop ELSE swap oners IF fiver THEN THEN ; : #r ( digit -- digit' ) 10 /mod swap digit 2 column# +! ; : roman ( number -- ) column# off <<# #r #r #r #r 0 #> type #>> ;
\ No newline at end of file
......@@ -88,7 +88,7 @@ database implements
swap dup +in +! move ;
: >$ ( addr u -- ) +in off $+ ;
: >0" ( addr u -- addr ) >$ tmpbuf @ ;
: #+ ( n -- ) extend under dabs <# #S rot sign #> $+ ;
: #+ ( n -- ) extend under dabs <<# #S rot sign #> $+ #>> ;
: ,+ ( -- ) state @ IF s" , " $+ THEN state on ;
\ basic operations 01apr98py
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment