\ 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