Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Menu Klasse Okay - Sudoku nicht?
| Uploader: |  Mae |
| Datum/Zeit: | 08.08.2008 13:36:19 |
' Hab' ich da was falsch verstanden?
' Die Sudoku-Klasse wird gleich angemeckert :-(
'##############################################################################
'## ##
'## FB Sudoku Helfer ##
'## ##
'## 2008-08-06 by Mae (Markus Merkle) Maeex(ät)gmx(dot)de ##
'## ##
'##############################################################################
' Achtung: Hippie 2.0 Lizenz!
' Software von Bürgern für freie Bürger.
' Wer dieses Programm in Deutschland nutzt muß das Grundgesetz anerkennen und
' sich auch bereit erklären dieses zu verteidigen. Laß nicht zu das die Stasi
' reinstalliert wird.
'
' Bitte setzen Dich für den erhalt der Menschenrechte ein.
' Schützen die Meinungs- u. Informationsfreiheit
' (siehe z.B.: www.Infokrieg.tv oder suche den Film "Zeitgeist")
' Laß die Liebe Regieren - nicht die Elite!
' Hör' nie auf das laufende System zu hinterfragen!!!
' !!! Kommentar (REM- und DATA Zeilen!) dürfen nicht verändert werden !!!
' An dieser Stelle darst Du jedoch Filmempfehlungen eintragen oder Seiten,
' die gegen die Versklavung kämpfen:
'------------------------------------------------------------------------------
' * http://alles-schallundrauch.blogspot.com
' * www.infokrieg.tv
' + http://www.youtube.com/watch?v=fJXfEbwYsp0
' + http://www.youtube.com/watch?v=tDdnq6IWWSA
' + http://www.youtube.com/watch?v=OSuWCIYi7T4
'------------------------------------------------------------------------------
Const My_Version = "0.0.1a" ' danke !
' Code für FreeBASIC
' Program-Doc: german
' FBC: 0.18b
' OS: XP Pro SP3
'------------------------------------------------------------------------------
' ToDo:
' - Oh: Das Sudokuspiel selbst fehlt ja noch...
' - Routinen die WrX, WrY als Vorgabe nutzen? ScreenInfo ist Sensor!!!
' - FlexMenu ist nicht Bug Resistent:
' Eine Menü Zeile die über den Bildrand hinausgeht würde vermutlich
' einen Programmabsturz verursachen, Sonderzeichen konvertierung in
' der Darstellung würde die SubMenüs nicht mehr finden lassen.
' - FlexMenu mit "Draw String" schreiben.
' Somit wäre es einfacher den InfoTyper parallel laufen zu lassen.
' Das Sonderzeichenproblem wäre auch Schnee von Gestern.
' Es könnte auch eine Scroll-Funktion gegen überlängen Bug...
' - Und hier und da: fehlt doch tatsächlich noch ein Kommentar!
' - Noch Platz finden für mehr Rechtschreibfehler.'
' History:
' 2008-08-07 - Mae: Sudoku-Klasse: SudokuMatrix
' 2008-08-07 - The_Muh: ANSI-ASCI Converter beigesteuert.
' 2008-08-06 - Mae: Programm zum Sudoku-Spiel umgebastelt.
' 2008-08-05 - Mae: FlexMenu Klasse läuft
' Fensterauflösung:
Const WrX = 1024, WrY = 768
' Bibliotheken:
#Include "fbgfx.bi"
' besondere Bibliotheksabschnitte:
Using fb
' Menü-Objekt für die Menü-Zeile:
Type FlexMenue
As UInteger xMax = 1024, yMax = 768, YP = 16
As UByte Zeile = 4, Rand = 3
As UInteger FarbeScr = RGB( 0, 0,200)
As UInteger FarbeTxt = RGB(150,150,150)
As UInteger FarbeBck = RGB( 0, 0,100)
As UInteger FarbeHiT = RGB(250,250,150)
As UInteger FarbeHiB = RGB( 0, 0,150)
As String MnuTxt(50) ' Derzeit 50 Einträge pro Ebene
As UInteger eMin = 1, eMax = 0 ' quasi LBound u. UBound
As Integer Ebene = -1, SelTitel = 0
As String Id ' Für einfache Auswertung: "Ebene.SelTitel"
As String Diese ' Für einfachen Kapitel-Sprung
Declare Sub InitEbene( ByVal MenuTitel As String = "" )
Declare Sub DruckMenu( ByVal Sel As UInteger = 0 )
Declare Function MenuPunkt As UInteger
End Type
Type SudokuMatrix
' 32 Bit je Feld Optimal nutzen? - och Nö!
' Dafür kann man dann aber auch mit Überschnittblöcken spielen,
' wodurch ein 10ter Neutralblock entsteht - Die Felder die keinem
' Block zugeordnet sind.
' Ob's Funktioniert - keine Ahnung...
Const UInteger B1 = 1 ' Feld gehört zum 1. NeuntelBlock
Const UInteger B2 = 2 ' Feld gehört zum 2. NeuntelBlock
Const UInteger B3 = 4 ' Feld gehört zum 3. NeuntelBlock
Const UInteger B4 = 8 ' Feld gehört zum 4. NeuntelBlock
Const UInteger B5 = 16 ' Feld gehört zum 5. NeuntelBlock
Const UInteger B6 = 32 ' Feld gehört zum 6. NeuntelBlock
Const UInteger B7 = 64 ' Feld gehört zum 7. NeuntelBlock
Const UInteger B8 = 128 ' Feld gehört zum 8. NeuntelBlock
Const UInteger B9 = 256 ' Feld gehört zum 9. NeuntelBlock
Const UInteger VF = 512 ' Feld ist ein Vorgabefeld
Const UInteger V1 = 2^10 ' Feld Wert 1
Const UInteger V2 = 2^11 ' Feld Wert 2
Const UInteger V3 = 2^12 ' Feld Wert 3
Const UInteger V4 = 2^13 ' Feld Wert 4
Const UInteger V5 = 2^14 ' Feld Wert 5
Const UInteger V6 = 2^15 ' Feld Wert 6
Const UInteger V7 = 2^16 ' Feld Wert 7
Const UInteger V8 = 2^17 ' Feld Wert 8
Const UInteger V9 = 2^18 ' Feld Wert 9
'...wo ich schon in Schwung bin:
Const UInteger R01 = 2^19 ' Reserviert 01
Const UInteger R02 = 2^20 ' Reserviert 02
Const UInteger R03 = 2^21 ' Reserviert 03
Const UInteger R04 = 2^22 ' Reserviert 04
Const UInteger R05 = 2^23 ' Reserviert 05
Const UInteger R06 = 2^24 ' Reserviert 06
Const UInteger R07 = 2^25 ' Reserviert 07
Const UInteger R08 = 2^26 ' Reserviert 08
Const UInteger R09 = 2^27 ' Reserviert 09
Const UInteger R10 = 2^27 ' Reserviert 10
Const UInteger R11 = 2^27 ' Reserviert 11
Const UInteger R12 = 2^27 ' Reserviert 12
Const UInteger R13 = 2^27 ' Reserviert 13
Const UInteger R14 = 2^27 ' Reserviert 14
' 9x9 Feld-Zustände festhalten:
As UInteger Felder( 1 To 9, 1 To 9)
' Spielsteuern:
Declare Sub KeineVorgaben
Declare Sub AllesIstMoeglich
Declare Sub BlockKiller
Declare Sub KlassikBlocks
' Spiel darstellen:
' Darstellungsbereich:
As UInteger RandOben, RandUnten, RandLinks, RandRechts
Declare Sub ZeichneSudoku
End Type
MenuItems: ' Hier sind derzeit keine Sonderzeichen erlaubt:
' Also bitte nur ASCI 32 ... 127 nutzen!
Data "Info", "Setup", "Start", "Laden", "Ende"
Data "*", "Info", "...verstanden!","?!?"
Data "-"
Info1:
Data "Dieses Programm soll unter unter einer neuen Hippie-Lizenz "
Data "gestellt werden, die sowohl im Programm-Code als auch am Ende dieses "
Data "Programmtextes Erwähnung findet!"
Data "*", "Beschleunige den Textfluß mit einer beliebigen Taste!"
Data "*", "*", "*", "Sudoku ", "(jap.: "
Data Chr$(34)+"Eine Zahl bleibt immer allein"+Chr$(34), ")"
Data "*", "*", "Das Logig-Rätsel wurde bereits vor 1800 vom Schweizer "
Data "Leonard Euler ", "erfunden."
Data "*","Doch Pupuläre wurde es erst 1986 in Japan "
Data "unter dem nun bekannten Namen."
Data "*","*","Das Rätsel besteht in einer Logischen Aufgabe, "
Data "und darf daher auch nur zu einer einzigen Lösung führen. "
Data "*", "*","Das klassische Sudoku besteht aus 9x9 Feldern. "
Data "Unterteilt in 3x3 Bereiche (Neuntel-Teilung). "
Data "In jeder Zeile und jeder Spalte darf ein Zeichen "
Data "- meist eine Zahl - ", "nur einmal Notiz finden. "
Data "Weiterhin darf sich eine Zeichen jedoch auch nicht innerhalb "
Data "eines Neuntels ", "(im Klassischem Sudoku) ", "wiederholen."
Data "*", "*", "Die Variationen des Sudokus bestehen in erster Linie "
Data "aus der veränderung der Größe. ", "Wobei ein kleineres Rätsel "
Data "mit einer kleineren Lösungsmenge und ein größeres mit einer "
Data "größeren Lösungsmenge gefüllt wird. "
Data "Für diese Varianten sind die Zahlen von 1 bis 9 weniger ideal! "
Data "Natürlich erstrecken sich Varianten auch in die 3. Diminsion. "
Data "*", "*"
Data "Doch auch 2 Diminsionale Sukodus bieten viel Raum für Variationen. "
Data "Im X-Sudoku sind 5 klassische Sudokufelder "
Data "zu einem X-Förmigen Spielfeld zusammengeschmolzen, "
Data "indem sich jedes Eck-Neuntel des in der mitte liegenden Sudokufeldes "
Data "das mit Neuntel überschneidend zu den je 4 angefügten teilt."
Data "*", "*"
Data "In diesem Programm geht es jedoch erst ein mal nur um "
Data "9er Quadrat Sudokus. ", "Eine Variation wird jedoch angeboten: "
Data "Die Neuntel müssen hier nicht Quadratisch sein, sondern können "
Data "jede beliebige Form haben, ", "solange Sie sich nicht im ganzen "
Data "mit einer Zeile oder Spalte überschneiden, "
Data "wo dieser Block sich ja darin auflösen würde."
Data "*", "Hier lassen sich die Blöcke sogar fragmentieren. "
Data "In diesem Falle wird hier von Zonen gesprochen, "
Data "da diese ja nicht mehr in einem geschlossenen Block angeordnet sind. "
Data "Zonen und Blöcke können sich sogar auf einem oder mehreren Feldern "
Data "überlagern. ", "Wenn jedoch ein Feld doppelt oder gar mehrfach ",
Data "belegt wurde - kann ein anderes Feld im gegenzug natürlich nicht mehr "
Data "belegt werden: Es entstehen dadurch Neutralfelder, "
Data "da hier keine zusätzlichen Blöcke oder Zonen gebildet werden. "
Data "Innerhalb dieser Neutralzone können sich Zeichen wiederholen. "
Data "*", "*"
Data "Es richtet sich jedoch auch an Anfänger die erlernen wollen, "
Data "wie man Sudokus löst oder eben echte Sudoku-Aufgaben generiert. "
Data "Hier soll ein eingebauter BOT entsprechende Hilfestellungen bieten."
Info2:
Data "*", "*"
Data "Da sich dieses Programm also an Leute richtet "
Data "die gewillt sind Ihr Logig-Verhalten zu trainieren wird folgende "
Data "Bedingung gestellt: ", "Wenn Sie dieses Programm nutzen sind Sie "
Data "damit einverstanden die Menschen-Rechte zu akzeptieren. "
Data "Meinungs- u. Informationsfreiheit zu schützen. ", "*"
Data "Sie verpflichten sich einen beliebigen Artikel von www.InfoKrieg.tv "
Data "einmal anzusehen oder anzuhören","*","*"
Data " Viel Spaß","*"
Data " euer Mäx"
Data "-"
' Unterprogramm, das eine Gittermatrix Zeichnet:
Declare Sub ZeichneMatrix _
( ByVal X As Integer,ByVal Y As integer)
Declare Sub FensterTitelMenu(MenuZeile As FlexMenue)
Declare Sub InfoSeite
' Funktion von The_Muh
Declare function conv(key as string) as String
' Maus:
Dim As Integer Maus, Mx, My, Mr, Mb
' Matrix:
Dim As Integer MatX = 9, MatY = 9
' Darf in Zeile, Spalte oder Block das Zeichen stehen?
Dim As String*9 DarfX, DarfY, DarfB
Dim As String*9 MarkX, MarkY, MarkB '
Dim As String*9 ZeigX, ZeigY, ZeigB
' Fenster:
Dim As Event ScrEvt
' Menü:
Dim shared MenuZeile As FlexMenue
' SudokuSpiel
Dim Shared MySudoku As SudokuMatrix
' Bildschirm initialisieren:
ScreenRes WrX, WrY, 32, 2
If ScreenPtr = 0 Then
Screen 1
Print "Mindestanforderungen unterschritten."
Sleep 3000
End -1
EndIf
WindowTitle "Mae: FB DrwStr FntEd"
Width Wrx\8, WrY\16
' Grund-Menü "laden":
MenuZeile.InitEbene
' Bildschirmaufbau:
FensterTitelMenu(MenuZeile)
' Programmschleife 1: Menu
Do
If (ScreenEvent(@ScrEvt)) Then
Select case ScrEvt.type
' MausBewegung:
Case Event_Mouse_Move
MenuZeile.DruckMenu(MenuZeile.MenuPunkt)
' MausTaste runter
Case EVENT_MOUSE_BUTTON_PRESS
MenuZeile.DruckMenu(MenuZeile.MenuPunkt)
Select Case MenuZeile.Id
Case ""
' Kein Menü erwischt!
Case "0.1" ' Info
Restore Info1
InfoSeite
MenuZeile.Zeile = 40
MenuZeile.InitEbene(MenuZeile.Diese)
MenuZeile.DruckMenu
Case "1.1" ' Hilfe.zurück
Line(0,81)-(WrX,WrY), RGB(0,0,0), bf
MenuZeile.Zeile = 4
MenuZeile.InitEbene
MenuZeile.DruckMenu
Case "0.2" ' Neu
MySudoku.KeineVorgaben
MySudoku.AllesIstMoeglich
MySudoku.KlassikBlocks
MySudoku.ZeichneSudoku
'ZeichneMatrix( MatX, MatY)
Case Else ' unbekanntes Menu
Color RGB(255,255,0), RGB(200,0,0)
Locate 1,1
Print "Unbekannte Menue-Id: " & MenuZeile.Id
Print "<" & MenuZeile.Diese & ">"
Print "Taste"
Sleep
While Inkey <> "": Wend
FensterTitelMenu(MenuZeile)
End Select
' Fenster wurde geschlossen
Case Event_Window_Close
Exit do
End select
EndIf
Loop While InKey$ <> Chr$(27)
' Klassisches Programm-Ende:
Ende:
'------------------------------------------------------------------------------
view Print
For i As UInteger = 1 To 50
sleep 10
Print
Next i
Print "Danke fuers Spielen!"
Print "euer Mae"
End 0
'---------------------------------------------------------------------------end
' Unterprogramme:
'---------------------------------------------------------------------------sub
Sub FensterTitelMenu(MenuZeile As FlexMenue)
' Bildschirmaufbau:
Line (0,0)-(WrX,80), RGB(0,0,200), bf
Color RGB(255,255,255),RGB(0,0,200)
Locate 2,2: Print "FreeBASIC 'Neuner Sudoku Helfer'"
Color RGB(150,150,150), RGB(0,0,100)
MenuZeile.DruckMenu
' Darstellungsbereich für das Sudokufeld:
With MySudoku
ScreenInfo(.RandRechts,.RandUnten)
.RandOben = 220
.RandLinks = 20
.RandRechts = .RandRechts - 20
.RandUnten = .RandUnten - 20
End With
End Sub
Sub InfoSeite
Dim As String StrTmp, StrOld
Dim As String BN , BL 'Buchstabe Now u. Last
Dim As UInteger FreiZeichen
Const RandR = 125 'Rechter Seitenrand
Const RandL = 4
Line(0,81)-(WrX,WrY), RGB(50,50,100), bf
Color RGB(255,255,255), RGB(50,50,100)
Locate 8, 3 : ? "FreeBASIC Sudoku Helfer"
Locate 10, 3 : ? "Version: " & My_Version
Locate 11, 3 : ? "Build: " & __DATE__
Line(0, 200) - (WrX, 600), RGB(150,150,250), bf
Color RGB(0,0,255), RGB(150,150,250)
View Print 14 To 37
Print Tab(4);
Do
StrOld = StrTmp
Read StrTmp
If StrTmp = "-" Then Exit Do
If StrTmp = "*" Then
If StrTmp <> StrOld then
Sleep 20 *Int(20*Rnd)
End if
Print : Print Tab(RandL);
Else
Sleep 300
For S As UInteger = 1 To Len(StrTmp)
BN = Mid$( StrTmp, S, 1)
Print conv(BN);
If BN = " " Then
FreiZeichen = InStr(S+1,StrTmp," ") -S
if Pos(0) + FreiZeichen > RandR Then
' Debug Zeile:
Print "<" & Pos(0) & "," & S & "," & InStr(S+1,StrTmp," ")
Print Tab(RandL)
'Print : Print Tab(RandL)
Sleep 20 *Int(20*Rnd)
EndIf
EndIf
If BN <> BL Then Sleep 50 + Int(50*Rnd)
BL = BN
' Nach einem Tastedruck wird schnell die Zeile gedruckt:
If InKey$ <> "" Then
For SE As UInteger = S+1 To Len(StrTmp)
BN = Mid$( StrTmp, SE, 1)
Print conv(BN);
If BN = " " Then
FreiZeichen = InStr(SE+1,StrTmp," ") -SE
if Pos(0) + FreiZeichen > RandR Then
Print : Print Tab(RandL)
Sleep 20 *Int(20*Rnd)
End If
End if
Next SE
Exit Do
End If
Next
EndIf
Loop While InKey$ = ""
Do
' Diese Schleife ist nicht notwendig wenn
' bereits vorherige das Data Ende erreicht hat:
If StrTmp = "-" Then Exit Do
' Ansonsten flott zu ende lesen:
Read StrTmp
Sleep 150
If StrTmp = "-" Then Exit Do
If StrTmp = "*" Then
Sleep 10
Print : Print Tab(RandL);
Else
For S As UInteger = 1 To Len(StrTmp)
BN = Mid$( StrTmp, S, 1)
Print conv(BN);
If BN = " " Then
FreiZeichen = InStr(S+1,StrTmp," ") -S
if Pos(0) + FreiZeichen > RandR Then
Print : Print Tab(RandL)
EndIf
EndIf
Next S
End if
Loop While InKey$ <> Chr$(27)
View Print
End Sub
' Funktion von The_Muh:
function conv(key as string) as string
dim con as string
dim ascl as integer
ascL = asc(left(key,1))
select case ascL
'case 167 : con = chr(245) '§
case 228 : con = chr(132) 'ä
case 196 : con = chr(142)
case 246 : con = chr(148) 'ö
case 214 : con = chr(153)
case 252 : con = chr(129) 'ü
case 220 : con = chr(154)
case 223 : con = chr(225) 'ß
case else: con = chr(ascl)
end Select
return con
end Function
Sub ZeichneMatrix(MatX As Integer, MatY As integer)
Dim As Integer StepX = (WrX/1.5) \ MatX, _
StepY = (WrY/1.5) \ MatY
Dim As Integer X, Y, XL, YL
Dim As Integer RO, RU, RL, RR
If StepX < StepY Then StepY = StepX Else StepX = StepY
XL = StepX*MatX
YL = StepY*MatY
X = WrX\2 - XL\2
Y = WrY\2 - YL\2
Line(X,Y)-(X+XL,Y+YL),RGB(50,50,50),bf
For iY As Integer = 0 To MatY-1
For iX As Integer = 0 To MatX-1
X = WrX\2 - StepX*MatY\2 + StepX *iX
Y = WrY\2 - StepY*MatY\2 + StepY *iY
Line(X, Y)-(X+StepX, Y+StepY), RGB(0,200,0),bf
Line(X +3, Y +3)-(X+StepX -3, Y+StepY -3), RGB(0,0,100),bf
Next
Next iy
End Sub
'##############################################################################
'## ##
'## Klasse FlexMenue 2008-08-05 Mae ##
'## ##
'##############################################################################
' Der Data-Bereich hinter Label MenuItems für das Menü.
' Die Sub-Menü-Ebenen werden durch "*" eingeleitet.
' Menü Data-Bereich muß mit "-" enden.
'------------------------------------------------------------------------------
' Xmax, Ymax : Screen-Pixel Width + Height
' YP : Y-Pixels (8, 14 oder 16 Pixel pro Zeile?)
' Ebene : aktuelle Menü-Ebene bzw. Kapitel
' Zeile : Auf welcher Zeile das Menü dargestellt wird
' Rand : Pixel Rand über und unter Menü-Zeile
' Farben des Menüs:
' FarbeScr : Bildschirm
' FarbeTxt : Text
' FarbeBck : Hintergrund
' FarbeHiT : Gewählter Text
' FarbeHiB : Gewählter Hintergrund
' MnuTxt() : leider kein Dyn Array möglich daher 50
' Menue-Ebene Einlesen:
Sub FlexMenue.InitEbene _
( ByVal MenuTitel As String = "" )
' Routine Variablen:
Dim As String StrTmp = ""
Dim As UInteger Nr, L, TL, B, BE
' Reset:
Restore MenuItems
eMin = 1 : eMax = 0 ' Da jetzt keine Einträge!
Ebene = 0
' Suche Menu Titel als Startpunkt:
While StrTmp <> Trim(MenuTitel)
Do ' Kapitelsprung (suche Ebene)
Read StrTmp
If StrTmp = "-" Then
' Menü-Eintrag nicht gefunden:
Color RGB(255,255,0), RGB(200,0,0)
Locate 1,1
Print "Unbekanntes Sub-Menue: "
Print "<" & MenuTitel & ">"
Print "Taste druecken oder Programmierer erschlagen..."
Sleep
While Inkey <> "": Wend
Exit Sub
EndIf
Loop Until StrTmp = "*"
Read StrTmp
Ebene += 1
Wend
Do ' Menu Ebene einlesen:
Read StrTmp
If StrTmp <> "*" Then ' Keine Kapitelmarken
If StrTmp <> "-" Then ' Keine Endmarke
Nr += 1
MnuTxt(Nr) = StrTmp
If Len(StrTmp) > L Then L = Len(StrTmp)
EndIf
EndIf
If StrTmp = "*" Or StrTmp = "-" Then Exit Do
Loop
' Vorne und Hinten ein Leerzeichen planen:
L += 2
' übertragen der Formatierung:
'ReDim MnuTxt(1 To Nr) ' <- O.o
For i As UInteger = 1 To Nr
B = L - Len(MnuTxt(i))
BE = B Mod 2
B \= 2
StrTmp = MnuTxt(i)
MnuTxt(i) = Space(B) & StrTmp & Space(B+BE)
Next i
eMax = Nr
End Sub
Sub FlexMenue.DruckMenu _
( ByVal Sel As UInteger = 0)
Dim As UInteger L, Z = Zeile -1
For i As Integer = eMin To eMax
If Len(MnuTxt(i)) > L Then L = Len(MnuTxt(i))
Next i
L += 2
ScreenSync
Line(0,YP*Z-Rand)-(XMax, YP*Z+YP+Rand), FarbeScr, bf
For i As UInteger = eMin To eMax
If i = sel Then
Color FarbeHiT, FarbeHiB
Else
Color FarbeTxt, FarbeBck
EndIf
Locate Zeile, (i-1) * L +2
Print MnuTxt(i)
Next i
Line(0,YP*Z -Rand)-(WrX, YP*Z), FarbeBck, bf
Line(0,YP*Z +YP )-(WrX, YP*Z +YP + Rand), FarbeBck, bf
End Sub
Function FlexMenue.MenuPunkt As UInteger
Dim As UInteger L, R, Z = Zeile -1
Dim As Integer X, Y
Id = ""
R = GetMouse(X, Y)
if R Then Exit Function
R = eMax - (eMin -1)
If R = 0 Then Exit Function
L = Len(MnuTxt(eMin)) +2
If Y > YP*Z-Rand\2 And Y < YP*Z+YP+Rand\2 Then
R = X\8 Mod L
If R > 0 And R < L-1 Then
Diese = MnuTxt(SelTitel)
SelTitel = (X\8) \ L +1
Id = Ebene & "." & SelTitel
Return SelTitel
EndIf
EndIf
End Function
'##############################################################################
'## ##
'## Klasse Sudoku-Matrix 2008-08-07 Mae ##
'## ##
'##############################################################################
' Der Data-Bereich hinter Label MenuItems für das Menü.
' Die Sub-Menü-Ebenen werden durch "*" eingeleitet.
' Menü Data-Bereich muß mit "-" enden.
Sub SudokuMatrix.KeineVorgaben
Dim As UByte X, Y
Dim As UInteger Wert = 0
' Bitmaske generieren mit fehlendem VF-Bit
For X = 0 To 31
If 2^X <> VF Then Wert = Wert Or 2^X
Next
' und nun überlagern:
For Y = 1 To 9
For X = 1 To 9
Felder(X,Y) = Felder(X,Y) And Wert
Next
Next
End Sub
Sub SudokuMatrix.AllesIstMoeglich
Dim As UByte X, Y
Dim As UInteger Wert = 0
' Bitmaske mit allen Möglichkeiten erstellen:
For X = 10 To 18
Wert = Wert Or 2^X
Next
' Alle Felder durchlaufen
For Y = 1 To 9
For X = 1 To 9
' Ist das Feld kein Vorgabe Feld:
If (Felder(X,Y) And VF) = 0 then
Felder(X,Y) = Felder(X,Y) Or Wert
End if
Next
Next
End Sub
Sub SudokuMatrix.BlockKiller
Dim As UByte X, Y, XD, YD
Dim As UInteger Wert = 0
' Bitmaske mit fehlenden Blockinformationen erstellen:
For X = 9 To 32
Wert = Wert Or 2^X
Next
' ...um diese zu entfehrnen:
For Y = 1 To 9
For X = 1 To 9
Felder(X,Y) = Felder(X,Y) And Wert
Next
Next
End Sub
Sub SudokuMatrix.KlassikBlocks
' Das passende Neuntel-Bit ermitteln und setzen:
For Y = 1 To 9
YD = (Y-1)\3 *3
For X = 1 To 9
XD = (X-1)\3
Wert = XD * YD
Felder(X,Y) = Felder(X,Y) Or (2^Wert)
Next
Next
End Sub
Sub ZeichneMatrix
Dim As Integer W, H, SW, SH, L, T
Dim As Integer StepX, _
StepY
Dim As Integer X1, Y1, X2, Y2
Dim As Integer Ro, Ru, Rl, Rr
Dim As UInteger Wert, BlockNow
' Arbeite im Zeichenbereich:
W = RandRechts - RandLinks
H = RandUnten - RandOben
StepX = W \ 9
StepY = H \ 9
' Jedes Kästchen soll Quadratisch bleiben:
If StepX < StepY Then StepY = StepX Else StepX = StepY
' Echte Größe des Sudokus:
SW = StepX * 9
SH = StepY * 9
' Position Top,Left
L = RandLinks +(W\2 -SW\2)
T = RandOben +(H\2 -WH\2)
' Bitmaske für die Blöcke erstellen:
For i As Integer = 1 To 9
Wert = Wert Or 2^i
Next
For Y = Integer 1 To 9
For X = Integer 1 To 9
X1 = L + X*StepX
Y1 = T + Y*StepY
X2 = L + X*StepX +StepX
Y2 = T + Y*StepY +StepY
BlockNow = Felder(X,Y) And Wert
If X > 1 Then
If Felder(X-1,Y) And BlockNow >0 Then
Ro = 1
Else
Ro = 2
EndIf
EndIf
Line(X1,Y1)-(X2,Y2), RGB(0,200,0),bf
Line(X1+RL,Y1+RO)-(X2+RR,Y2+RU), RGB(0,0,100),bf
Next
Next
End Sub