\ HEXADOKU.FTH   by Fred Behringer 

HEX

\ In Turbo-Forth und ZF vorhanden, jedoch nicht ANS
\ -------------------------------------------------

: ON ( ad -- ) -1 SWAP ! ;
: OFF ( ad -- ) 0 SWAP ! ;


\ Matrixaufbau
\ ------------

\ Alle Bearbeitungen (Zeilen-/Spalten-Vertauschung etc) nur fuer MATRIX.
\ Bei VORGABE wird zunaechst MATRIX nach V-MATRIX kopiert und die Vorgabewerte
\ werden in MATRIX gesammelt.
\ XCH-M tauscht MATRIX und V-MATRIX gegeneinander aus.

\ Hexadoku-Matrix, zeilenweise, pro Element ein Byte
VARIABLE MATRIX 0FF ALLOT

\ Vorgabe-Matrix, vom selben Aufbau wie MATRIX
VARIABLE V-MATRIX 0FF ALLOT

\ MATRIX nach V-MATRIX kopieren
: CPY-M ( -- ) 100 0
   DO MATRIX I + C@ V-MATRIX I + C! LOOP ;

\ MATRIX mit V-MATRIX vertauschen
: XCH-M ( -- ) 100 0
   DO MATRIX I + C@ V-MATRIX I + C@ MATRIX I + C! V-MATRIX I + C! LOOP ;

\ MATRIX zu etwa 50% mit vorgegebenen Elementen belegen
\ seed = Anfangsbyte im RAM fuer Zufallsauswahl
\ Kleinerer Belegungsprozentsatz gelingt durch mehrfache Anwendung
: AUSWAHL ( seed -- )
   100 0 DO DUP I + C@ 1 AND 0= IF 20 I MATRIX + C! THEN LOOP DROP ;

\ Vorher MATRIX sichern
: VORGABE ( seed -- ) CPY-M AUSWAHL XCH-M ;


\ MATRIX-Elemente
\ ---------------

\ Adresse ad[ij] von Element a[ij] in MATRIX, i = Zeile, j = Spalte
: AD[IJ] ( i j -- ad[ij] ) SWAP 10 * + MATRIX + ;

\ Hole Element a[ij] von MATRIX
: A[IJ]@ ( i j -- a[ij] ) AD[IJ] C@ ;

\ Speichere Element a[ij] nach MATRIX
: A[IJ]! ( a[ij] i j -- ) AD[IJ] C! ;


\ Zeilen und Spalten
\ ------------------

\ Hole Zeile  i von MATRIX, letztes Element zuerst auf Stack, I=j !
: A[I.]@ ( i -- a[i.] ) 00 0F DO DUP I A[ij]@ SWAP -1 +LOOP DROP ;

\ Hole Spalte j von MATRIX, letztes Element zuerst auf Stack, I=i !
: A[.J]@ ( j -- a[.j] ) 00 0F DO I OVER A[IJ]@ SWAP -1 +LOOP DROP ;

\ Speichere  Zeile i von MATRIX, juengstes Stack-Element zuerst ins RAM, I=j !
: A[I.]! ( a[i.] i -- ) 10 00 DO SWAP OVER I A[IJ]! LOOP DROP ;

\ Speichere Spalte j von MATRIX, juengstes Stack-Element zuerst ins RAM, I=i !
: A[.J]! ( a[i.] j -- ) 10 00 DO SWAP OVER I SWAP A[IJ]! LOOP DROP ;


\ Rotationen und Konstantenaddition
\ ---------------------------------

\ Linksrotation der Zeile i von MATRIX um 1 Spalte
: ROL1[I.] ( i -- ) >R R@ 0 A[ij]@ R@ A[i.]@ DROP R> A[i.]! ;

\ Linksrotation der Zeile i von MATRIX um 4 Spalten
: ROL4[I.] ( i -- ) 4 0 DO DUP ROL1[I.] LOOP DROP ;

\ Addition von 4*n zu saemtlichen Elementen von MATRIX
: ADD4 ( n -- ) 4 *
    100 0 DO DUP MATRIX I + C@ + 10 MOD MATRIX I + C! LOOP DROP ;

\ Rechtsrotation der Zeile i von MATRIX um 1 Spalte
: ROR1[I.] ( i -- ) >R R@ A[i.]@ R@ 0F A[ij]@ R> A[i.]! DROP ;

\ Rechtsrotation der Zeile i von MATRIX um 4 Spalten
: ROR4[I.] ( i -- ) 4 0 DO DUP ROR1[I.] LOOP DROP ;


\ Bildschirmdarstellungen
\ -----------------------

\ Spaltensprung
: J+ ( i -- ) DUP 0> SWAP 4 MOD 0= AND IF SPACE THEN ;

\ ASCII --> Ziffernausgabe
: ZIFF ( n i -- ) J+ DUP 0F U> IF EMIT SPACE ELSE . THEN ;

\ Zeilensprung
: I+ ( i -- ) DUP 0> SWAP 4 MOD 0= AND IF    CR THEN ;

\ Bildschirmdarstellung von MATRIX
: .M ( -- ) 10 0 DO I I+ CR I A[I.]@ 10 0 DO I ZIFF LOOP LOOP ;

\ Bildschirmdarstellung von V-MATRIX
: .V ( -- )  CR 10 0
   DO I I+ 24 SPACES 10 0
      DO V-MATRIX J 10 * + I + C@ I ZIFF
      LOOP CR
   LOOP ;

\ Bildschirmdarstellung von MATRIX & V-MATRIX
: .M&V ( -- ) CR 10 0
   DO 10 0 DO   MATRIX J 10 * + I + C@ I ZIFF LOOP 5 SPACES
      10 0 DO V-MATRIX J 10 * + I + C@ I ZIFF LOOP CR I 1+ I+
   LOOP ;


\ Abwandlungen von MATRIX
\ -----------------------

\ Kanonische Matrix --> MATRIX
: KANON ( -- )
   00 0F DO I -1 +LOOP 00 A[I.]!
   10 01 DO I 4 MOD 0=
           IF   I 04 - A[I.]@ I A[I.]! I ROL1[I.]
           ELSE I 01 - A[I.]@ I A[I.]! I ROL4[I.]
           THEN
         LOOP ;

\ Linkskanonische Matrix --> MATRIX
: KANONL ( -- ) KANON ;

\ Rechtskanonische Matrix --> MATRIX; entspricht KANON mit ROR statt ROL.
: KANONR ( -- )
   00 0F DO I -1 +LOOP 00 A[I.]!
   10 01 DO I 4 MOD 0=
           IF   I 04 - A[I.]@ I A[I.]! I ROR1[I.]
           ELSE I 01 - A[I.]@ I A[I.]! I ROR4[I.]
           THEN
         LOOP ;

\ Transponierte von MATRIX, a[ij] <--> a[ji] fuer i < j
: TRANSP ( -- )
   10 0 DO
   10 0 DO I J < IF I J A[IJ]@ J I A[IJ]@ I J A[IJ]! J I A[IJ]! THEN
        LOOP
        LOOP ;

\ Viererquadrate und Streifen
\ ---------------------------

\ Aus Zeile/Spalte mach Viererquadrat  (0...f)
: IJ>V ( i j -- v )  4 / SWAP 4 / 4 * + ;

\ Aus Zeile/Spalte mach Querstreifen   (0...3)
: IJ>Q ( i j -- q )  DROP 4 / 4 * ;

\ Aus Zeile/Spalte mach Laengsstreifen (0...3)
: IJ>L ( i j -- l )  NIP  4 / 4 * ;

\ Aus Quer/Laengs  mach Viererquadrat  (0...f)
: QL>V ( q l -- v )  SWAP 4 * + ;

\ Aus Viererquadrat mach Quer/Laengs   (0..3, 0..3)
: V>QL ( v -- q l )  4 /MOD SWAP ;

\ Tausche Zeile  i1 in MATRIX gegen Zeile  i2
: XCHI ( i1 i2 -- )
   >R >R R@ A[I.]@ R> R@ SWAP >R A[I.]@ R> A[I.]! R> A[I.]! ;

\ Tausche Spalte j1 in MATRIX gegen Spalte j2
: XCHJ ( j1 j2 -- )
   >R >R R@ A[.J]@ R> R@ SWAP >R A[.J]@ R> A[.J]! R> A[.J]! ;

\ Kehre Zeilenfolge  in MATRIX um ( i <--> 0f-i )
: INVERSI ( -- )  8 0 DO I 0F I - XCHI LOOP ;

\ Kehre Spaltenfolge in MATRIX um ( j <--> 0f-j )
: INVERSJ ( -- )  8 0 DO I 0F I - XCHJ LOOP ;

\ Tausche Querstreifen   q1 in MATRIX gegen Querstreifen   q2
: XCHQ ( q1 q2 -- ) 4 MOD SWAP 4 MOD
   4 0 DO 2DUP 4 * I + SWAP 4 * I + XCHI LOOP 2DROP ;

\ Tausche Laengsstreifen l1 in MATRIX gegen Laengsstreifen l2
: XCHL ( l1 l2 -- ) TRANSP XCHQ TRANSP ;


\ Hauptprogramm: Folge von Hexadokus
\ ----------------------------------

\ Zaehler
VARIABLE INDEX

\ Bildschirmanzeige mit zugehoeriger Loesung (LOES? = ON/OFF)?
VARIABLE LOES?
LOES? ON       \ Default
\ Start von HEXA bei kanonischer MATRIX?
VARIABLE KANON?
KANON? ON      \ Default

\ Beliebig viele Vorgabematrizen erzeugen und anzeigen.
\ Bei LOES? OFF nur Vorgaben, bei LOES? ON auch Loesungen.
\ KANON? ON : Start mit kanonischer MATRIX
\ Return-Taste oder [q] oder [Q] = raus, andere Taste = naechstes Bild.
: HEXA ( -- ) 
   ." Taste oder ( [ret] oder [q] oder [Q] ) druecken!" CR
   2000 INDEX ! ( seed zu Beginn der Folge )
   KANON? @ IF KANON THEN
   BEGIN
     KEY DUP
     0D ( [ret] ) = OVER 71 ( q ) = OR SWAP 51 ( Q ) = OR IF EXIT THEN
     5 INDEX +!
     INDEX @ C@ 1 AND IF TRANSP  THEN 3 INDEX +!
     INDEX @ C@ 1 AND IF INVERSI THEN 3 INDEX +!
     INDEX @ C@ 1 AND IF INVERSJ THEN 3 INDEX +!
     INDEX @ C@ INDEX @ 1+ C@    XCHQ 3 INDEX +!
     INDEX @ C@ INDEX @ 1+ C@    XCHL 3 INDEX +!
     INDEX @ C@                  ADD4 3 INDEX +!
     INDEX @ C@ 4 / 4 * 10 MOD DUP
     INDEX @ 1+ C@ 4 MOD + SWAP INDEX @ 2 + C@ 4 MOD + XCHI 5 INDEX +!
     INDEX @ C@ 4 / 4 * 10 MOD DUP
     INDEX @ 1+ C@ 4 MOD + SWAP INDEX @ 2 + C@ 4 MOD + XCHJ 5 INDEX +!
     INDEX @ VORGABE LOES? @ IF .M&V ELSE .V THEN
     CR ." Weiter mit Taste, raus mit [ret] oder [q] oder [Q] !"
   AGAIN ;


\ Zulaessigkeitspruefungen
\ ------------------------

\ Tritt n in Zeile i mindestens zweimal auf ? Meldung, wenn ja.
\ Funktioniert auch fuer Leerstellen (n=20h)
: 2*INI? ( n i -- )
   INDEX OFF 10 * MATRIX +
   10 0 DO 2DUP I + C@ = IF 1 INDEX +! THEN LOOP 2DROP
   INDEX @ 1 > ABORT" Mindestens zweimal!" ;

\ Tritt n in Spalte j mindestens zweimal auf ? Meldung, wenn ja.
\ Funktioniert auch fuer Leerstellen (n=20h)
: 2*INJ? ( n j -- ) TRANSP 2*INI? TRANSP ;

\ Tritt n im Viererquadrat v mindestens zweimal auf ?
\ Funktioniert auch fuer Leerstellen (n=20h)
: 2*INV? ( n v -- )
   INDEX OFF V>QL SWAP 10 * + 4 * MATRIX +
   4 0 DO 2DUP I + C@ = IF 1 INDEX +! THEN LOOP 10 +
   4 0 DO 2DUP I + C@ = IF 1 INDEX +! THEN LOOP 10 +
   4 0 DO 2DUP I + C@ = IF 1 INDEX +! THEN LOOP 10 +
   4 0 DO 2DUP I + C@ = IF 1 INDEX +! THEN LOOP 10 + 2DROP
   INDEX @ 1 > ABORT" Mindestens zweimal!" ;

\ Ist MATRIX zulaessig? Meldung, wenn nicht.
: MOK? ( -- )
   10 0 DO 10 0 DO J I 2*INI? LOOP LOOP
   10 0 DO 10 0 DO J I 2*INJ? LOOP LOOP
   10 0 DO 10 0 DO J I 2*INV? LOOP LOOP ;

\ finis