====== 4d2008-01 Listings ======

===== 1-wire.fs =====

<file>

\ 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

</file>

===== 1wire implementation =====

<file>

#! 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

</file>

===== Projekt Euler - p146 =====

<file>

#! /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


</file>

===== Cursor Togglen =====

<file>

\ 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.


</file>

===== word scrambler =====

<file>

\ 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

</file>