4d2008-01 Listings
1-wire.fs
\ 1-wire interface
[IFUNDEF] set-baud include serial.fs [THEN]
0 Value 1-wire-fd
also dos
: set-tty ( fd -- ) filehandle @ >r
t_old r@ tcgetattr drop
t_old t_buf sizeof termios move
$805 t_buf termios c_iflag !
$000 t_buf termios c_oflag !
$8BD t_buf termios c_cflag !
0 t_buf termios c_lflag !
0 t_buf termios c_cc VMIN + c!
3 t_buf termios c_cc VTIME + c!
$D dup t_buf termios c_ispeed ! t_buf termios c_ospeed !
t_buf 1 r> tcsetattr drop ;
previous
: open-1-wire ( addr u -- ) r/w open-file throw to 1-wire-fd
1-wire-fd set-tty ;
s" /dev/ttyUSB0" open-1-wire
: 1w-write ( addr u -- )
1-wire-fd write-file throw ;
: 1w-read ( addr u -- n )
1-wire-fd read-file throw ;
: 1w? ( -- n ) 1-wire-fd check-read ;
$E3 Constant :cmd
$E1 Constant :data
$C1 Constant :reset
$C5 Constant :reset2
$BE Constant :read
$B1 Constant :accel
$A1 Constant :accel-off
Create cmdbuf 0 c,
Create 'cmd :cmd c, 0 c, :data c,
Create 'address 8 0 [DO] 0 c, [LOOP]
Create 'dummies 16 0 [DO] $FF c, [LOOP]
Create 'search 16 0 [DO] 0 c, [LOOP]
Create 'stuff $17 c, $45 c, $5b c, $0f c, $91 c,
Variable results $100 allot
Variable timeout
: waitx &10 wait timeout @ 0 after - 0< ;
: >results ( n -- ) &100 after timeout !
BEGIN dup 1-wire-fd check-read > WHILE waitx UNTIL
results off true abort" Timeout" ELSE
results cell+ swap 1w-read results ! THEN ;
: .results ( -- ) base push hex
results @+ swap bounds ?DO
I c@ 3 .r LOOP ;
: >address ( -- )
'address 8 erase
$40 0 DO results cell+ I 2* 1+ bit@ IF
'address I +bit
THEN LOOP ;
Code bswap AX bswap Next end-code macro
: "address ( -- addr u ) base push hex
>address 'address 2@ bswap swap bswap swap
<# # # '# hold 12 0 DO # LOOP '. hold # # #> ;
: .address "address type ;
: maxdisc ( -- n ) 0
$40 0 DO results cell+ I 2* bit@ IF drop I THEN LOOP ;
: cmd ( n -- ) cmdbuf c! cmdbuf 1 1w-write ;
: cmdr ( n -- ) cmd 1 >results ;
: addr ( -- ) 'address 8 1w-write 8 >results ;
: dummies8 ( -- ) 'dummies 8 1w-write 8 >results ;
: dummies9 ( -- ) 'dummies 9 1w-write 9 >results ;
: search16 ( -- ) 'search 16 1w-write 16 >results ;
: >temp ( -- ) base push decimal results cell+ w@ 2/
&100 * results cell+ 6 + c@ &100 results cell+ 7 + c@ */ - &75 +
extend under dabs <# 'C hold '° xhold # # '. hold #S rot sign #> ;
: .temp ( -- ) >temp type ;
: >cmd ( n -- ) 'cmd 1+ c! 'cmd 3 1w-write ;
: >cmdr ( n -- ) >cmd 1 >results ;
: reset2 ( -- ) :reset2 >cmdr ;
: init ( -- ) :reset >cmdr 'stuff 5 1w-write 5 >results reset2 ;
: accel ( -- ) :accel >cmd ;
: accel-off ( -- ) :accel-off >cmd ;
\ "skip ROM": no address
: noaddress reset2 $CC cmdr ;
\ "search ROM": apply an address
: address
reset2 $55 cmdr addr ;
: search-first ( -- ) 'search 16 erase
init $F0 cmdr accel search16 accel-off ;
: search-next ( -- ) results cell+ 'search 16 move
'search maxdisc 2* 1+ +bit
$40 maxdisc 1+ DO 'search I 2* 1+ -bit LOOP
init $F0 cmdr accel search16 accel-off ;
: search-all ( -- ) search-first .address cr maxdisc
BEGIN search-next .address cr maxdisc tuck = UNTIL drop ;
: readout
noaddress
$44 cmdr &750 ms \ convert temperature
noaddress
$BE cmdr \ read scratchpad
dummies9 ;
: readrom \ would work if host didn't reply as well
reset2 $33 cmdr
dummies8 ;
init search-first >address
1wire implementation
#! xbigforth
\ automatic generated code
\ do not edit
also editor also minos also forth
component class ds1920-f5
public:
early widget
early open
early dialog
early open-app
infotextfield ptr temp
varbox ptr devices
text-label ptr dev-first
( [varstart] ) ( [varend] )
how:
: open new DF[ 0 ]DF s" DS 1920-F5 sensor" open-component ;
: dialog new DF[ 0 ]DF s" DS 1920-F5 sensor" open-dialog ;
: open-app new DF[ 0 ]DF s" DS 1920-F5 sensor" open-application ;
class;
include 1wire.fs
ds1920-f5 implements
( [methodstart] ) : show super show
search-first ^^ 0 T[ ][ ]T "address rbutton new
dev-first widgets self devices add maxdisc
BEGIN search-next ^^ 0 T[ ][ ]T "address rbutton new
dev-first widgets self devices add maxdisc tuck = UNTIL
drop
^ 1 $1000 dup NewTask pass >o
BEGIN readout >temp temp assign AGAIN ; ( [methodend] )
: widget ( [dumpstart] )
^^ ST[ ]ST ( MINOS ) T" " X" Temperature:" infotextfield new ^^bind temp
X" Devices:" text-label new ^^bind dev-first
&1 varbox new ^^bind devices
&2 vabox new panel
( [dumpend] ) ;
: init ^>^^ assign widget 1 :: init ;
class;
: main
ds1920-f5 open-app
$1 0 ?DO stop LOOP bye ;
script? [IF] main [THEN]
previous previous previous
Projekt Euler - p146
#! /usr/bin/gforth
\ ---- logic and shift words for double cell operands -------------------------
: dand ( d d -- d ) rot and >r and r> ;
: dinvert ( d -- d ) swap invert swap invert ;
: dlshift ( d u -- d ) 0 ?do d2* loop ;
: dor ( d d -- d ) rot or >r or r> ;
: dnot ( d -- 0.|1. ) d0= abs s>d ;
: drshift ( d u -- d ) 0 ?do d2/ loop dabs ;
: dxor ( d d -- d ) rot xor >r xor r> ;
\ ---- ran4 : a random number generator ---------------------------------------
: (FuncG) ( d dc1 dc2 -- d )
2>r dxor 2dup um* 2swap dup um* dinvert rot dup um* d+ swap 2r> dxor d+
;
: (PseudoDes) ( d d -- d d )
2swap 2over $BAA96887E34C383B. $4B0F3B583D02B5F8. (FuncG) dxor
2swap 2over $1E17D32C39F74033. $E874F0C39226BF1A. (FuncG) dxor
2swap 2over $03BCDC3C60B43DA7. $6955C5A61D38CD47. (FuncG) dxor
2swap 2over $0F33D1B265E9215B. $55A7CA46F358B432. (FuncG) dxor
;
2variable Counter
2variable Sequence#
: start-sequence ( dcounter dseq# -- ) Sequence# 2! Counter 2! ;
: ran4 ( -- d )
Sequence# 2@ Counter 2@ (PseudoDes)
2swap 2drop
Counter 2@ 1. d+ Counter 2!
;
\ ---- arithmetic words for unsigned double cell operands ---------------------
: d* ( d d -- d ) 3 pick * >r tuck * >r um* r> + r> + ;
: t* ( ud un -- ut ) dup rot um* 2>r um* 0 2r> d+ ;
: t/ ( ut un -- ud )
>r r@ um/mod swap
rot 0 r@ um/mod swap
rot r> um/mod swap drop
0 2swap swap d+
;
: u*/ ( ud un un -- ud ) >r t* r> t/ ;
\ initialize SUPERBASE (normally $100000000. on 32 bits machine, with fallback value of $10000.)
s" max-u" environment? 0= [if] $10000. [then] 0 1. d+ 2constant SUPERBASE
: d/ { D: u D: v -- ud_quot }
v 0. d= if -10 throw then \ throw for division by zero
v u du> if 0. exit then \ if v is bigger then 0.
v u d= if 1. exit then \ if v is equal then 1.
v 0= if >r u 1 r> u*/ exit then \ use mixed precision word
drop
v { v1 v0 } \ v = v0 * b + v1
v0 -1 = if 1 else SUPERBASE 1 v0 1+ u*/ drop then { d } \ d = b/(v0+1)
v d 1 u*/ { w1 w0 } \ w = d * v = w0 * b + w1
u over 0 w1 w0 u*/ d- d w0 u*/ nip 0
;
: dmod { D: d1 D: d2 -- d } d1 2dup d2 d/ d2 d* d- ;
: dumin ( d1 d2 -- d ) 2over 2over du> if 2swap then 2drop ; \ d is min(d1,d2)
\ initialize UMAX (normally $ffffffffffffffff. on 32 bits machine, with fallback value of $ffffffff.)
s" max-ud" environment? 0= [if] $ffffffff. [then] 2constant UMAX
: d+mod { D: a D: b D: m -- d } \ addition modulo m
a m dmod to a \ normalize a
b m dmod to b \ normalize b
a UMAX b d- d<= if \ no overflow..
a b d+ m dmod exit \ ..built-in computation
then
\ ---- go with the algorithm ;-)
a m a d- dumin { D: aA }
b m b d- dumin { D: bB }
b bB d= ( -- f ) \ leave a flag on stack
a aA d= if
bB aA du> if
if aA bB d+ m dmod else m bB aA d- d- then exit ( f -- ) \ ..consume the flag
else
>r aA bB r> if d+ else d- then m dmod exit ( f -- ) \ ..consume the flag
then
else
if aA bB du> if m aA bB else m m bB aA d- then d- d- exit then ( f -- ) \ ..consume the flag
then
m aA bB d+ m dmod d-
;
: d*mod { D: a D: b D: m -- d } \ multiplication modulo m
a m dmod to a \ normalize a
b m dmod to b \ normalize b
a 1. d= if b exit then
b 1. d= if a exit then
a m a d- dumin { D: aA }
b m b d- dumin { D: bB }
aA d0= bB d0= or if 0. exit then
aA 1. d= if m b d- exit then
bB 1. d= if m a d- exit then
aA a d= bB b d= and aA a d<> bB b d<> and or { pos } \ pos is True if positive, False otherwise
aA UMAX bB d/ du<= if
aA bB d* m dmod pos 0= if m 2swap d- m dmod then exit
then
aA d2/ { D: a0 }
aA a0 d- { D: a1 }
bB d2/ { D: b0 }
bB b0 d- { D: b1 }
a1 b1 m recurse { D: p4 }
0. 0. 0. { D: p1 D: p2 D: p3 }
a0 a1 d= b0 b1 d= and if
p4 to p1
p4 to p2
p4 to p3
else
a0 a1 d= if
p4 m a1 d- m dmod m d+mod 2dup to p3
to p1
p4 to p2
else
p4 m b1 d- m dmod m d+mod to p2
b0 b1 d= if
p2 to p1
p4 to p3
else
p4 m a1 d- m dmod m b1 d- m dmod 1. m d+mod m d+mod m d+mod to p1
p4 m a1 d- m dmod m d+mod to p3
then
then
then
p1 p2 p3 p4 m d+mod m d+mod m d+mod pos 0= if m 2swap d- m dmod then
;
: d**mod { D: base D: power D: m -- d } \ exponentiation modulo m
1. { D: res }
begin power 0. du> while
1. power dand drop if \ if power is odd
res base m d*mod to res
then
base base m d*mod to base
power 1 drshift to power
repeat
res
;
: miller_rabin { D: n W: rounds -- f }
n 1. du<= if false exit then
n 19. du<= if
n drop \ to use single cell in the following tests
dup 2 = if drop true exit then
dup 3 = if drop true exit then
dup 5 = if drop true exit then
dup 7 = if drop true exit then
dup 11 = if drop true exit then
dup 13 = if drop true exit then
dup 17 = if drop true exit then
19 = if true exit then \ do not dup in the last test
false exit
else
n 2. dmod 0. d= if false exit then
n 3. dmod 0. d= if false exit then
n 5. dmod 0. d= if false exit then
n 7. dmod 0. d= if false exit then
n 11. dmod 0. d= if false exit then
n 13. dmod 0. d= if false exit then
n 17. dmod 0. d= if false exit then
n 19. dmod 0. d= if false exit then
then
n 1. d- { D: d }
0 { W: s }
begin d 1. dand 0. d= while
d 1 drshift to d
s 1+ to s
repeat
0. 0. 0. 0 { D: a D: tst D: Rbig W: Rsmall }
begin rounds 1- dup to rounds 0> while
ran4 n 1. d- dmod 1. d+ to a
a d n d**mod 1. du<> if
1. to Rbig
0 to Rsmall
begin Rsmall s u< while
a Rbig d d* n d**mod to tst \ tst = powmod( a, R * d, n )
n 1. d- tst du= if
s to Rsmall \ cause a break from the loop
else
Rbig Rbig d+ to Rbig \ double Rbig
Rsmall 1+ to Rsmall
then
repeat
n 1. d- tst du<> if
false exit \ return false (composite number)
then
then
repeat
true \ return true (maybe prime)
;
\ ---- main and its internal words --------------------------------------------
: (main-inc-p) ( u -- u ) dup 2 + 3 mod 0= if 4 else 2 then + ;
: (main-ba) { W: n -- n' }
11 { W: p }
0 { W: nd }
n s>d 2dup d* { D: n2 }
begin
n2 p s>d dmod d>s to nd
nd 1+ p mod 0= if 0 exit then
nd 3 + p mod 0= if 0 exit then
nd 7 + p mod 0= if 0 exit then
nd 9 + p mod 0= if 0 exit then
nd 13 + p mod 0= if 0 exit then
nd 27 + p mod 0= if 0 exit then
p (main-inc-p) to p \ inc. p by 2 or by 4
p n 1+ > if
n2 15. d+ 10 miller_rabin if 0 exit then
n2 19. d+ 10 miller_rabin if 0 exit then
n2 21. d+ 10 miller_rabin if 0 exit then
n2 25. d+ 10 miller_rabin if 0 exit then
." Found n=" n . cr
n exit
then
again
;
: main { W: limit -- d }
0. { D: sum }
limit 1+ 10 do \ i must be divisible by 10, loop only through multiples of 10
i 3 mod 0<> if \ i can't be divisible by 3
i 4 + 7 mod 1 <= if \ i % 7 must be either 3 or 4
i (main-ba) s>d sum d+ to sum
then
then
10 +loop
." sum=" sum ud. cr
;
150000000 main
bye
Cursor Togglen
\ CursorTogglen.fs
hex
code curs-on ( -- ) \ Cursor einschalten
ds di mov \ Datensegment aufbewahren,
bx bx xor bx ds mov \ dann auf 0 setzen.
460 [bx] cx mov \ Rasterzeilen: ch oben, cl unten
di ds mov \ Datensegment wiederherstellen
1f # ch and \ Bits 5-7 der obersten Rasterzeile auf 0
1 # ah mov \ Interrupt-Funktion nach ah
10 int \ Bildschirm-Interrupt aufrufen
next end-code
code curs-off ( -- ) \ Cursor ausschalten
ds di mov \ mov-Operationen beziehen sich
bx bx xor bx ds mov \ auf das Datensegment ds
460 [bx] cx mov
di ds mov
e0 # ch or \ Bits 5-7 der obersten Rasterzeile auf 1
1 # ah mov 10 int
next end-code
code curs-togg ( -- ) \ Cursor umschalten
ds di mov
bx bx xor bx ds mov
460 [bx] cx mov
di ds mov
e0 # ch xor \ Bits 5-7 der obers. Rasterz. 0/1 -> 1/0
1 # ah mov 10 int
next end-code
code curs-shape ( anf end -- ) \ Cursor-Formgebung
ds di mov
bx bx xor bx ds mov
460 [bx] cx mov
di ds mov
ax pop \ Unterste Cursor-Rasterzeile auf
1f # al and al cl mov \ (0..1f) beschränken und nach cl legen.
ax pop \ Oberste Cursor-Rasterzeile auf
1f # al and \ (0..1f) beschränken, dann bisherigen
e0 # ch and \ Einschaltzustand (Bits 5-7) retten
al ch or \ und beides nach ch zusammenführen.
1 # ah mov 10 int
next end-code
\ Der so implementierte Cursor kann auch im ausgeschalteten
\ Zustand (im Verborgenen) neu geformt werden, ohne dass er
\ sich dadurch schon einschaltet. Beim anschließenden
\ Einschalten zeigt er dann seine neueingestellte Form.
word scrambler
\ word scrambler based on random shuffle
vocabulary scrambler
scrambler definitions
variable seed
base @ hex 10450405 constant generator
base !
: rnd ( -- n ) seed @ generator UM* DROP 1+ DUP seed ! ;
: random ( n -- 0..n-1 ) rnd UM* NIP ;
: init ( -- )
TIME&DATE 12 * + 31 * + 24 * + 60 * + 60 * + seed ! ; init
: c>< ( c-addr1 c-addr2 -- ) \ character exchange
2dup c@ ( c-addr1 c-addr2 c-addr-1 c2 )
swap c@ ( c-addr1 c-addr2 c2 c1 )
rot c! ( c-addr1 c2 )
swap c! ;
: cshuffle ( c-addr n -- ) \ shuffle Durstenfeld/Knuth
BEGIN ?dup WHILE ( c-addr i )
2dup 1- chars + >r
2dup random chars + r> c><
1-
REPEAT drop ;
: scramble-word2 ( c-addr len -- ) \ some case handling included.
dup 4 < IF 2drop exit THEN
dup 4 = IF over char+ dup char+ c>< 2drop exit THEN
2 - swap char+ swap cshuffle ;
: scramble ( <word> -- )
cr
BEGIN
bl word count
dup
WHILE ( c-addr len )
2dup scramble-word2 type space
REPEAT
2drop ;
words
scramble sah ein knab ein röslein stehen
cr cr
\ study random behavior, execute serveral times.
\ : xxx ( -- ) 0 10 do cr i . i random . -1 +loop ;
\ scramble (.) (.O) (.:O) (.:=O) (.:=#O) (.:=#*O)
\ finis