4d2006-03 Listings

\ 2006-07-31 SMBus.fs --- SMBus Basiscode
\ i2c Bus am R8C
\ P1.0 -- SCL
\ P1.1 -- SDA

\ Konstanten
0     Constant PinSCL
1     Constant PinSDA
port1 Constant PortI2C
$E3   Constant PddrI2C

\ SDA,SCL Pins auf 0 oder 1 setzen
: sda0 PinSDA PortI2C bclr ;
: sda1 PinSDA PortI2C bset ;
: scl0 PinSCL PortI2C bclr ;
: scl1 PinSCL PortI2C bset ;

\ 1 SCL Zyklus sind im Programm 4 ticks
: tick 1 us ;
: 2tick tick tick ;

\ sende 1 Bit
: bit>i2c ( bit -- )
    IF sda1 ELSE sda0 ENDIF
    tick scl1 2tick scl0 tick ;

\ erzeuge Bit Nr. i aus Byte x als 0 oder 1
: getBit ( x i -- b ) rshift $01 and ;

\ sende 1 Byte, (8 Bit) "most significant bit" zuerst
: >i2c ( x -- )
    8 0 DO
	dup 8 I 1+ - getBit
	bit>i2c
    LOOP
    drop ;

\ sende START, STOP, REPEATED_START
: i2c_start ( -- ) tick sda0 2tick scl0 tick ;
: i2c_stop  ( -- ) tick scl1 2tick sda1 tick ;
: i2c_rstart sda1 tick scl1 tick sda0 tick scl0 tick ;

\ setze SDA zum Lesen / Senden
: sdaInput  ( -- ) PinSDA PddrI2C bclr ;
: sdaOutput ( -- ) PinSDA PddrI2C bset ;

\ lies SDA
: readSDA   ( -- f )
    PinSDA PortI2C btst IF 1 ELSE 0 ENDIF ;

\ lies 1 Byte (8 Bit), "most significant bit" zuerst
: <i2c ( -- x )
    sdaInput
    0
    8 0 DO
	1 lshift
	tick scl1 tick readSDA tick scl0 tick
	+
    LOOP
    sdaOutput ;

\ lies ACK (0) oder NACK (1) vom Partner
: ack<i2c ( -- f )
    sdaInput
    tick scl1 tick readSDA tick scl0 tick
    sdaOutput ;

\ sende N Bytes nach Adresse addr
\ das "most significant Byte" liegt oben auf dem Stapel
: NB>i2c ( x1 .. xN.msB N addr -- )
    i2c_start               \ START
    >i2c ack<i2c drop       \ ADRESSE senden, ACK lesen
    0 DO                    \ Schleife, nimmt N vom Stapel
	>i2c ack<i2c drop   \   DATA_BYTE verschicken
    LOOP                    \ Ende Schleife
    i2c_stop                \ STOP
;

\ lies N Bytes von Adresse addr
\ das "least significant Byte" liegt oben auf dem Stapel
\ Adresse und ControlByte sind schon verschickt
: NB<i2c ( N addr -- xN.msB .. x1 )
    i2c_rstart              \ REPEATED_START
    1+ >i2c ack<i2c drop    \ ADRESSE | READ senden, ACK lesen
    1- dup 0 > IF           \ Schleife ueber N-1 Byte
	0 DO                \   Datenbyte = 0 (initialisieren)
	    <i2c 0 bit>i2c  \   DATA_BYTE lesen, ACK schicken
	LOOP                \ Ende Schleife
    ENDIF                   \
    <i2c 1 bit>i2c          \ letzes Byte lesen, NACK schicken
    i2c_stop		    \ STOP
;

\ finis

\ 2006-06-28 EW adv_01.fs
\
\ i2c_bus connected to r8c
\ P1.0 -- SCL
\ P1.1 -- SDA
\ device PCF8574 (8bit IO) at address $20

rom

include SMBus.fs

$40   Constant i2c_addr_portexpander

\ send Byte x to portexpander
: >portexpander ( x -- )
    i2c_start                  \ START
    i2c_addr_portexpander >i2c \ Adresse schreiben
    ack<i2c drop               \ ACK lesen und verwerfen
    >i2c                       \ Datenbyte schreiben
    ack<i2c drop               \ ACK lesen und verwerfen
    i2c_stop                   \ STOP
;

\ watch the show!
Variable N
0 N !
: run
    0 >portexpander
    1000 ms
    BEGIN
	N @
	dup invert >portexpander
	1+ N !
	1000 ms
    key? UNTIL
;

ram

\ finis

\ 2006-06-28 EW adv_02.fs
\
\ i2c Bus am R8C
\ P1.0 -- SCL
\ P1.1 -- SDA
\ am Bus:
\ PCF8574 (8bit IO), 7-bit Adresse: $20

rom

include SMBus.fs

$40   Constant i2c_addr_portexpander

\ vom portexpander lesen
: <portexpander ( -- x )
    $ff                     \ "ControlByte"
    1 i2c_addr_portexpander NB>i2c
    1 i2c_addr_portexpander NB<i2c
;

ram

\ finis

\ 2006-06-28 EW adv_03.fs --- Thermometer
\
\ i2c Bus am R8C
\ P1.0 -- SCL
\ P1.1 -- SDA
\ am Bus:
\ PCF8574 (8bit IO), 7-bit Adresse: $20
\ LM75 (Thermometer, 9-bit signed, 7-bit Adresse: $4f

rom

include SMBus.fs

$9e   Constant i2c_addr_lm75

: get.T ( -- xh xl )
    $00                     \ ControlByte
    1 i2c_addr_lm75 NB>i2c  \ verschicken
    2 i2c_addr_lm75 NB<i2c  \ 2 Byte lesen
;

: decode.T ( xh xl -- T*10 )
    $80 and                 \ die ungueltigen Bits loeschen
    swap                    \ xh nach oben holen
    8 lshift                \ xh << 8
    +                       \ == (xh << 8) + ( xl & 0x80)
    5 128 */                \ == T*10
; 

\ _always_ display sign '+' or '-'
: sign! 0 < IF 45 ELSE 43 ENDIF hold ;

\ format T for display (type or lcdtype)
: format.T ( T*10 -- )
    dup >R                  \ store copy for sign
    abs s>d                 \ remove sign, make double
    \ 1 digit, "." 2digits sign_always
    \ Numbers >= 1000 are truncated in the high digits!!!
    <# # 46 hold # # R> sign! #> \ == "%+5.1f"
;

\ write string to lcd position col (0..15) row (0..1)
\ with next lcdtype    
: lcdpos ( row col -- )
    swap $40 * + $80 + lcdctrl! &1 ms ;

: thermometer
    lcdpage
    BEGIN
	0 5 lcdpos
	get.T decode.T format.T lcdtype
	250 ms
    key? UNTIL
;

ram

\ finis

\ Nach geladenem Gforth-R8C ueber die Tastatur in das
\ RAM des R8Cs eingeben. Danach per SAVESYSTEM 
\ "festfrieren". Kann per EMPTY bis auf das eigentliche
\ Forth-System geloescht werden.

\ Ich verwende im gesamten Programm Grossschreibung.
\ Kleinschreibung reicht aber. Das System ist auf
\ egal voreingestellt.

HEX

\ Sudoku-Matrix, zeilenweise, pro Element ein Byte
CREATE M

0 C, 1 C, 2 C,  3 C, 4 C, 5 C,  6 C, 7 C, 8 C,
3 C, 4 C, 5 C,  6 C, 7 C, 8 C,  0 C, 1 C, 2 C,
6 C, 7 C, 8 C,  0 C, 1 C, 2 C,  3 C, 4 C, 5 C,

1 C, 2 C, 3 C,  4 C, 5 C, 6 C,  7 C, 8 C, 0 C,
4 C, 5 C, 6 C,  7 C, 8 C, 0 C,  1 C, 2 C, 3 C,
7 C, 8 C, 0 C,  1 C, 2 C, 3 C,  4 C, 5 C, 6 C,

2 C, 3 C, 4 C,  5 C, 6 C, 7 C,  8 C, 0 C, 1 C,
5 C, 6 C, 7 C,  8 C, 0 C, 1 C,  2 C, 3 C, 4 C,
8 C, 0 C, 1 C,  2 C, 3 C, 4 C,  5 C, 6 C, 7 C,

\ Hole Element in Zeile i und Spalte j von Matrix M
: IJ@ ( i j -- a[ij] ) SWAP 9 * + M + C@ ;

\ Speichere Element in Zeile i und Spalte j nach Matrix M
: IJ! ( a[ij] i j -- ) SWAP 9 * + M + C! ;

\ Addiere n modulo 9 zu saemtlichen Elementen von Matrix M
: ADDn ( n -- )
    51 0 DO DUP M I + C@ + 9 MOD M I + C! LOOP DROP ;

\ INDEX
VARIABLE IX

\ Vertausche willkuerlich 2 Spalten einer Laengsdreierreihe in Matrix M
: XCHJ ( -- ) IX @ C@ 9 0
   DO DUP 9 MOD DUP DUP 3 MOD 0> IF 1 - ELSE 1+ THEN
     2DUP I SWAP IJ@ I ROT IJ@ ROT I SWAP IJ! I ROT IJ!
   LOOP DROP ;

\ Vertausche Zeile 3 und 5 und Zeile 7 und 8 in Matrix M
: XCHI ( -- ) 9 0
   DO 3 I IJ@ 5 I IJ@ 3 I IJ! 5 I IJ! 7 I IJ@ 8 I IJ@ 7 I IJ! 8 I IJ!
   LOOP ;

\ ASCII --> Ziffernausgabe
: ZIFF ( n -- ) DUP 8 U> IF DROP SPACE SPACE ELSE 1+ . THEN ;

\ IX um 5 weitersetzen
: I5+! ( -- ) IX @ DUP 600 > IF 300 - THEN 5 + IX ! ;

\ Zufaellige Auslassungen
\ Etwa 27d Elemente bleiben als Vorgabe stehen. Breite Streuung!
: RAND ( n -- m ) IX @ C@ 3 MOD IF DROP 20 THEN I5+! ;

\ Bildschirmdarstellung von geaenderter Vorgabematrix
: V ( -- ) CR 9 0
   DO 9 0 DO J I IJ@      ZIFF LOOP 5 SPACES
      9 0 DO J I IJ@ RAND ZIFF LOOP CR
   LOOP ;

\ Neue Sudoku-Matrix mit passender Vorgabematrix
: S ( -- ) IX @ C@  ADDN  XCHI  XCHJ  I5+! V ;

\ Will man zu ein und derselben (Loesungs-)Matrix M verschiedene
\ Vorgabematrizen erzeugen, dann rufe man (beliebig oft) V auf.
\ Bei jedem erneuten Aufruf von V wird die bis dato erreichte
\ Sudoku-Matrix M beibehalten, waehrend die Vorgabematrix neu er-
\ zeugt wird.

\ Selbstverstaendlich kann man eine erreichte Vorgabematrix
\ auch per Hand ausbessern: Man uebernehme (und notiere auf
\ Papier) nur, sagen wir, 27d Elemente oder ergaenze (bei zu
\ wenigen Vorgabeelementen) Elemente durch Einfuegen von der
\ Sudoku-Matrix M her.

\ Man kann eine erreichte Sudoku-Matrix M auch per Hand aendern:
\ Dazu stehen die drei Forth-Worte  x ADDN  XCHI  XCHJ  (in
\ beliebiger Anwendungsreihenfolge) zur Verfuegung. x kann
\ eine beliebige Zahl sein.

\ Geaenderte Vorgabe-Matrizen bei gleichbleibender Sudoku-
\ Matrix werden durch V angezeigt. Geaenderte Sudoku-Matrizen
\ mit passender Vorgabe-Matrix werden durch S angezeigt.

\ Solche Tastatureingaben muessen natuerlich immer durch
\ [return] abgeschlossen werden, um Wirksamkeit zu erlangen.

( Arithmetik in Galois Feldern, Grundkoerper F_p )
: Restklassen ;
variable F_pp
2 F_pp ! \ Vorbesetzung  mit 2
: F_p+ ( a b -- a+b ) + F_pp @ mod ;
: F_p- ( a b -- a-b ) - F_pp @ mod ;
: F_p* ( a b -- a*b ) * F_pp @ mod ;
: F_p/ ( a b -- a/b )
    swap 0 swap ( b 0 a) ( oder b q r )
    begin
      rot dup >r       \ q r b 
      /mod             \ q r delta-q 
      rot +            \ r q 
      r> swap rot dup  \ b q r r
      F_pp @ + swap    \ b q r' r
      0=
    until
    drop swap drop ;

\ Einrichtung des gesonderten F_p^n Stapels entfaellt hier
\ ************ weil nur fuer F_p^2 *******************

2             constant F_p^nn
F_p^nn cell * constant F_p^2#bytes \ Speicherplatz fuer eine Zahl aus F_p^2

\ --------------------------------------------------------------
\ Arithmetik fuer Galois-Felder F_p^n auf dem Parameterstapel
\ nur Spezialfall n=2 und Polynom a^2+a+1=0
\ dieses Polynom ist irreduzibel fuer z. B. p= 2, 5
: F_p^2+  ( a0 a1 b0 b1 -- a0+b0 a1+b1 )
   swap >r f_p+ swap r> f_p+ swap ;
: F_p^2-  ( a0 a1 b0 b1 -- a0-bo a1-b1 )
   swap >r f_p- swap r> f_p- swap ;
 : F_p^2*   ( a0 a1 b0 b1 -- c0 c1 )
                            \ c0 = a0*b0 - a1*b1 
                            \ c1 = a1*b0 + a0*b1 - a1*b1
 dup >r swap dup >r  \ a0 a1 b1 b0                   |R        b0 b1
 rot dup >r f_p*     \ a0 b1 a1*b0                   |R     a1 b0 b1
 rot dup >r          \ b1 a1*b0 a0                   |R  a0 a1 b0 b1
 rot f_p* f_p+       \ a1*b0+a0*b1                   |R  a0 a1 b0 b1
 r> r> r> rot        \ a1*b0+a0*b1 a1 b0 a0          |R           b1
 f_p* swap r> f_p*   \ a1*b0+a0*b1 a0*b0 a1*b1       |R        
 dup >r f_p-         \ a1*b0+a0*b1 a0*b0-a1*b1       |R        a1 b1 
 swap r> f_p- ;      \ a0*b0-a1*b1 a1*b0+a0*b1-a1*b1 |R

: konj ( a0 a1 -- a0+a1 a1 )
 dup rot f_p+ swap ; \ nur falls Polynom  a^2+a+1=0  korrekt
 
: F_p^2/   ( a0 a1 b0 b1 - c0 c1 )
\ aehnlich wie durch Erweiterung mit dem konjugiert komplexen Nenner
\ machbar, Als Uebungsaufgabe empfohlen.
                            ;
\ -----------------------------------------------------------------
\ Variablen und Konstanten
: F_p^2variable
  create [ F_p^2#bytes ] literal allot ;
: F_p^2!
  dup [ F_p^2#bytes 1- ] literal + swap
  do
     i ! 4
  +loop ;

: F_p^2@ dup 1- swap [ F_p^2#bytes 2 / ] literal +
  do
    i @ -4
  +loop ;
 f_p^2variable test

\ finis