scrabble code

[Τράγου Κέρατο]

Δώσε output με input το abcde για να καταλάβω...

[dimulator]

Input: abc

 

Output:

abc

acb

cab

cba

abc

acb

 

λείπουν τα

bac

bca

 

και εμφανίζει διπλά τα abc, acb

ενώ το πλήθος των λέξεων είναι σωστό!

Edited November 9, 2009 by dimulator

[Τράγου Κέρατο]

Χμ... Το μόνο στο οποίο μου πηγαίνει το μυαλό είναι μήπως η VB χειρίζεται τις local μεταβλητές διαφορετικά από ό,τι οι άλλες γλώσσες. Συμπεριφέρεται σαν να περνάνε οι μεταβλητές by reference και όχι by value. Μπορείς να το επαληθεύσεις αυτό;

 

Update:

 

Μόλις τώρα το βρήκα:

 

In Visual Basic 6.0, if you do not specify ByVal or ByRef for a procedure parameter, the passing mechanism defaults to ByRef. This allows the variable passed into the procedure to be modified in the calling program.

 

Πιθανότατα το ίδιο συμβαίνει και στην έκδοσή σου.

 

Κάνε την παρακάτω αλλαγή:

 

Private Function anag(ByVal iStart As Integer,ByVal  iLen As Integer,ByVal sArray() As String)

'Port code from phpAG

'FIXME H synartisi enw einai idia me ayth tou phpAG den douleuei gia kapoio logo
'dokimase leksi me tria grammata gia na deis ti kanei p.x. abc

   If iStart < iLen Then
       j = iStart
       While (j < iLen)

           If j = iStart Or sArray(j) <> sArray(iStart) Then
               tmp = sArray(j)
               sArray(j) = sArray(iStart)
               sArray(iStart) = tmp
               Call anag((iStart + 1), iLen, sArray())
           End If

       j = j + 1
       Wend
   Else
       word = implode(sArray())
       Text2.Text = Text2.Text & word & vbNewLine

 End If

Edited November 9, 2009 by Τράγου Κέρατο

[dimulator]

Εύγε! Τελικά αυτό ήταν το ByVal και όχι ByRef.

Αλλά έπρεπε να κάνω και μια ακόμη αλλαγή. Οι πίνακες στην VB δεν περνάνε ByVal και έπρεπε αντί πίνακα να είναι Variant.

 

Τελικά ο κώδικας είναι ο εξής και λειτουγεί σωστά.

 

Private Sub Command1_Click()

Dim iLen As Integer                     'Set word length

iLen = Len(Text1.Text)                  'Get word length
ReDim sArray(iLen) As String            'Set an array with elements as many are letters of word

For i = 0 To iLen                       'Split word into letters and put every letter in array
sArray(i) = Mid(Text1.Text, i + 1, 1)
Next

Text2.Text = ""                         'Reset and clear output textbox to be ready to get new results

Call anag(0, iLen, sArray())            'Make anagrams

End Sub

--------------------------------------------------------------------------------

Private Function anag(ByVal iStart As Integer, ByVal iLen As Integer, ByVal sArray As Variant)

'Port code from phpAG

   If iStart < iLen Then
       j = iStart
       While (j < iLen)

           If j = iStart Or sArray(j) <> sArray(iStart) Then
               tmp = sArray(j)
               sArray(j) = sArray(iStart)
               sArray(iStart) = tmp
               Call anag((iStart + 1), iLen, sArray)
           End If

       j = j + 1
       Wend
   Else
       word = implode(sArray)
       Text2.Text = Text2.Text & word & vbNewLine

 End If


End Function

--------------------------------------------------------------------------------

Private Function implode(sArray As Variant) As String
'This function makes a string from the elements of a string array

For i = 0 To UBound(sArray)
word = word & sArray(i)
Next

implode = word
End Function

--------------------------------------------------------------------------------


Private Sub Text1_keypress(KeyAscii As Integer)

If KeyAscii = 13 Then 'if user press enter
   Call Command1_Click
End If

End Sub

Edited November 10, 2009 by dimulator

[dimulator]

Λοιπόν με τιμή σας παρουσιάζω την έκδοση του Anagramatismos σε γραφικό περιβάλον φτιαγμένο σε Visual Basic, μια παραγωγή του Τράγοκέρατου και Dimulator αφιερωμένη στο ΑρτΟφΓουάης.

 

Οδηγίες:

Κατεβάστε το αρχείο Anagramatismos.zip

Αποσυμπιέστε το με το WinZip, ή WinRar

Μέσα στο φάκελο "Αναγραμματισμός VB" θα βρήτε το εκτελέσιμο Anagramatismos.exe το οποίο είναι η εφαρμογή

Όλα τα άλλα αρχεία είναι τα αρχεία κατασκευής της VB και δεν χρειάζονται από τον τελικό χρήστη παρά μόνο από προγραμματιστές για να δουν τον κώδικα.

 

Καλή διασκέδαση!

Anagramatismos.zip

Edited November 10, 2009 by dimulator

[Speedy]

Μπράβο παιδιά! Ευχαριστούμε!

 

Σε όσους λείπει το msvbvm50.dll μπορούν να το κατεβάσουν από εδώ:

 

http://www.dll-files.com/dllindex/dll-files.shtml?msvbvm50

[dimulator]

θα έκανα και Setup αλλά δεν λειτουργεί ο Setup Wizzard της VB5 στα ΧΡ...

αν κάποιος ξέρει πως να κάνω σεταπ θα είναι πλήρες.

 

το πρόβλημα στο σεταπ ειναι αυτό

http://support.microsoft.com/kb/170372/en-us

 

θα δω τι μπορώ να κάνω

 

μάλλον το διόρθωσα...

Edited November 10, 2009 by dimulator

[Τράγου Κέρατο]

Κι όσοι θέλετε να αποφύγετε τα μπλεξίματα με setup και dll που λείπουν, απλώς παίρνετε την έκδοση σε C.

[dimulator]

Ακόμη μια έκδοση του προγράμματος που ψαχνει κάθε λέξη σε Ελληνικό ή Αγγλικό λεξικό.

 

Στην ουσία έχω εξάγει το Ελληνικό και Αγγλικό λεξικό του aspell σε αρχεία txt και το ψάξιμο γίνεται από αυτά.

 

Λειτουργία:

1) ο χρήστης εισάγει τα γράμματα

2) Παράγει τις αναγραμματισμένες λέξεις

3) Επιλέγει λεξικό

4) Κάνει την εύρεση στο λεξικό

 

Τα αρχεία

aspell-el-no_accent.txt

aspell-en.txt

Anagramatismos.exe

 

πρέπει να είναι μαζί στον ίδιο φάκελο

 

Μπορείτε να προσθέσετε δικάς σας αρχεία txt στο ίδιο φάκελο με δικές σας λέξεις.

Τα αρχεία txt απλά είναι λίστες λέξεων, δείτε για παράδειγμα το aspell-en.txt

 

** Προειδοποίηση **

Η διαδικασία εύρεσης είναι πολύ χρονοβόρα σε μεγάλα λεξικά όπως αυτά του aspell!

Edited November 10, 2009 by dimulator

[dimulator]

θα έκανα και Setup αλλά δεν λειτουργεί ο Setup Wizzard της VB5 στα ΧΡ...

αν κάποιος ξέρει πως να κάνω σεταπ θα είναι πλήρες.

 

το πρόβλημα στο σεταπ ειναι αυτό

http://support.microsoft.com/kb/170372/en-us

 

θα δω τι μπορώ να κάνω

 

μάλλον το διόρθωσα...

 

Έκανα και setup κανονικά αλλά αν και συμπιεσμένο είναι μεγαλύτερο από 2ΜΒ και δεν μπορώ να το ανεβάσω!

[dimulator]

Ο κώδικας για να τον δείτε είναι ο εξής:

 

Private Sub Command1_Click()

Dim iLen As Integer                     'Set word length
Dim sMyPath As String                   'Set Path for tmp file
Dim sMyName As String                   'Set Name for tmp file

iLen = Len(Text1.Text)                  'Get word length
ReDim sArray(iLen) As String            'Set an array with elements as many are letters of word

For i = 0 To iLen                       'Split word into letters and put every letter in array
sArray(i) = Mid(Text1.Text, i + 1, 1)
Next

Text2.Text = ""                         'Reset and clear output textbox to be ready to get new results


sMyPath = "./anagram.tmp"
sMyName = Dir(sMyPath)   ' Retrieve the first entry.

'Close file if it is open
Close #2

If sMyName <> "" Then
   'Del anagram.tmp
   Kill sMyName
End If

'Open file for writing
Open "anagram.tmp" For Append As #2    ' Open file for output.

Call anag(0, iLen, sArray())            'Make anagrams

Close #2

End Sub

-----------------------------------------------------------------------------------

Private Function anag(ByVal iStart As Integer, ByVal iLen As Integer, ByVal sArray As Variant)


'Port code from phpAG

   If iStart < iLen Then
       j = iStart
       While (j < iLen)

           If j = iStart Or sArray(j) <> sArray(iStart) Then
               tmp = sArray(j)
               sArray(j) = sArray(iStart)
               sArray(iStart) = tmp
               Call anag((iStart + 1), iLen, sArray)
           End If

       j = j + 1
       Wend
   Else
       word = implode(sArray)
       Text2.Text = Text2.Text & word & vbNewLine
       Print #2, word 'write to anagram.tmp the result

 End If

End Function

-----------------------------------------------------------------------------------

Private Function implode(sArray As Variant) As String
'This function makes a string from the elements of a string array

For i = 0 To UBound(sArray)
word = word & sArray(i)
Next

implode = word
End Function

-----------------------------------------------------------------------------------

Private Sub Command2_Click()

Dim sResponse As String
Dim sWord1 As String
Dim sWord2 As String

'Clear old text, get ready for new results
Text3.Text = ""

'If there is at least one word in Text2 search in dictionary
If Len(Text2.Text) > 0 Then

   Screen.MousePointer = vbHourglass
   Command1.Enabled = False
   Command2.Enabled = False

   'open file from Combo1
   Open (Combo1.Text) For Input As #1

       Do While Not EOF(1)                                         'Loop until end of file 1.

           Line Input #1, sWord1                                   'Read line from file into variable.

           Open ("anagram.tmp") For Input As #3
           Do While Not EOF(3)                                     'Loop until end of file 3
              Line Input #3, sWord2                                'Read each line from file3
              If sWord1 = sWord2 Then                              'Compare two words
                 Text3.Text = Text3.Text & sWord2 & vbNewLine      'if much add to text3
              End If
           DoEvents
           Loop
           Close #3

           DoEvents
       Loop
   Close #1
   Command1.Enabled = True
   Command2.Enabled = True
   Screen.MousePointer = vbDefault
Else
   'Inform user that there is nothing to search
   sResponse = MsgBox("Äåí õðÜñ÷ïõí ëÝîåéò ãéá åýñåóç!", vbInformation)
End If



End Sub

-----------------------------------------------------------------------------------

Private Sub Form_Load()

Dim sMyPath As String
Dim sMyName As String

'Clear Combo1
Combo1.Clear

'Check in running directory for dictionary files *.txt
sMyPath = "./*.txt"
sMyName = Dir(sMyPath)   ' Retrieve the first entry.
Do While sMyName <> ""   ' Start the loop.
   Combo1.AddItem (sMyName)
   sMyName = Dir    ' Get next entry.
Loop

'Set Combo1 text
Combo1.Text = Combo1.List(0)

End Sub

-----------------------------------------------------------------------------------

Private Sub Text1_keypress(KeyAscii As Integer)

If KeyAscii = 13 Then 'if user press enter
   Call Command1_Click
End If

End Sub

[dimulator]

Και το τελευταίο προγραμματάκι το RevrseLexarithm

 

Με αυτό το πρόγραμμα βρήσκετε τις λέξεις που έχουν λεξάριθμο το νούμερο που βάζετε.

Για παράδειγμα ποιες λέξεις έχουν λεξάριθμο το 543;

 

Η εύρεση γίνεται στο αρχείο txt του λεξικού aspell.

Αν θέλετε μπορείτε να ανοίξετε το αρχείο αυτό και να προσθέσετε λέξεις την μία κάτω από την άλλη κάνοντας λίστα.

 

** Προσοχή ** λόγο του ότι το αρχείο txt είναι τεράστιο το πρόγραμμα αργεί πολύ.

 

Αν θέλετε μπορείτε να έχετε πολλά λεξικά. Όλα θα πρέπει να είναι απλές λίστες λέξεων στα Ελληνικά στον ίδιο φάκελο με το ReverseLexarithm.exe.

 

Κάθε φορά επιλέγετε ένα λεξικό από την λίστα.

 

Το πρόγραμμα λειτουργεί μόνο με Ελληνικές λέξεις! Επίσης μπορείτε να έχετε λέξεις με τα γράμματα

Δίγαμα (F), Κόπα (Q), Σαμπί (S)

Edited November 10, 2009 by dimulator

[dimulator]

Να και ο κώδικας του ReverseLexarithm

 

Private Sub Command2_Click()

Dim sResponse As String
Dim sWord1 As String
Dim iLexarithm As Integer


'Clear old text, get ready for new results
Text3.Text = ""

'if user entered a number
If IsNumeric(Val(Text1.Text)) And (Val(Text1.Text)) > 0 Then

   Screen.MousePointer = vbHourglass
   Command2.Enabled = False

   'open file from Combo1
   Open (Combo1.Text) For Input As #1

       Do While Not EOF(1)                                         'Loop until end of file 1.

           Line Input #1, sWord1                                   'Read line from file into variable.
           iLexarithm = GetLexarithm(sWord1)

           If iLexarithm = Val(Text1.Text) Then
              Text3.Text = Text3.Text & sWord1 & vbNewLine
           End If

           DoEvents
       Loop
   Close #1
   Command2.Enabled = True
   Screen.MousePointer = vbDefault
Else
   'Inform user that there is nothing to search
   sResponse = MsgBox("ÅéóÜãåôå Ýíáí áñéèìü!", vbInformation)
End If

End Sub

--------------------------------------------------------------------------

Private Function GetLexarithm(ByVal sWord As String) As Integer

Dim iArray(1 To 27) As Integer
Dim sArray(1 To 27) As String
Dim iLen As Integer                     'Set word length
Dim iLex As Integer
iLen = Len(sWord)                       'Get word length
ReDim sLetters(iLen) As String            'Set an array with elements as many are letters of word


'Set Greek Lexarithmic values in an array
iArray(1) = 1 'Á
iArray(2) = 2 'Â
iArray(3) = 3 'Ã
iArray(4) = 4 'Ä
iArray(5) = 5 'Å
iArray(6) = 6 'F
iArray(7) = 7 'Z
iArray(8) = 8 'H
iArray(9) = 9 'È
iArray(10) = 10 'É
iArray(11) = 20 'Ê
iArray(12) = 30 'Ë
iArray(13) = 40 'Ì
iArray(14) = 50 'Í
iArray(15) = 60 'Î
iArray(16) = 70 'Ï
iArray(17) = 80 'Ð
iArray(18) = 90 'Q
iArray(19) = 100 'Ñ
iArray(20) = 200 'Ó
iArray(21) = 300 'Ô
iArray(22) = 400 'Õ
iArray(23) = 500 'Ö
iArray(24) = 600 '×
iArray(25) = 700 'Ø
iArray(26) = 800 'Ù
iArray(27) = 900 'S (SAMPI)

'Set Greek Letters in an array
sArray(1) = "Á" 'Á
sArray(2) = "Â" 'Â
sArray(3) = "Ã" 'Ã
sArray(4) = "Ä" 'Ä
sArray(5) = "Å" 'Å
sArray(6) = "F" 'F (DIGAMA)
sArray(7) = "Æ" 'Z
sArray(8) = "Ç" 'H
sArray(9) = "È" 'È
sArray(10) = "É" 'É
sArray(11) = "Ê" 'Ê
sArray(12) = "Ë" 'Ë
sArray(13) = "Ì" 'Ì
sArray(14) = "Í" 'Í
sArray(15) = "Î" 'Î
sArray(16) = "Ï" 'Ï
sArray(17) = "Ð" 'Ð
sArray(18) = "Q" 'Q (KOPA)
sArray(19) = "Ñ" 'Ñ
sArray(20) = "Ó" 'Ó
sArray(21) = "Ô" 'Ô
sArray(22) = "Õ" 'Õ
sArray(23) = "Ö" 'Ö
sArray(24) = "×" '×
sArray(25) = "Ø" 'Ø
sArray(26) = "Ù" 'Ù
sArray(27) = "S" 'S (SAMPI)

For i = 0 To iLen                       'Split word into letters and put every letter in array
sLetters(i) = Mid(UCase(sWord), i + 1, 1)
Next

For i = 0 To (UBound(sLetters)) 'for each letter search in sArray for letters
   j = 0
   For j = 1 To 27
       If (sArray(j) = sLetters(i)) And (sArray(j) <> "") Then
          'MsgBox ("sArray=" & sArray(j) & " " & "sLetters=" & sLetters(i))
          iLex = iLex + iArray(j)
       End If
   Next
Next

GetLexarithm = iLex

End Function

--------------------------------------------------------------------------

Private Sub Form_Load()

Dim sMyPath As String
Dim sMyName As String

'Clear Combo1
Combo1.Clear

'Check in running directory for dictionary files *.txt
sMyPath = "./*.txt"
sMyName = Dir(sMyPath)   ' Retrieve the first entry.
Do While sMyName <> ""   ' Start the loop.
   Combo1.AddItem (sMyName)
   sMyName = Dir    ' Get next entry.
Loop

'Set Combo1 text
Combo1.Text = Combo1.List(0)

End Sub

--------------------------------------------------------------------------

Private Sub Text1_keypress(KeyAscii As Integer)

If KeyAscii = 13 Then 'if user press enter
   Call Command2_Click
End If

End Sub

[dimulator]

Σημείωση: Αν προσθέσετε λέξεις ή αν κάνετε το δικό σας aspell-el-no_accent.txt θα πρέπει οι λέξεις να μην έχουν τόνους.

 

Καλή διασκέδαση!

[dimulator]

Lykon νομίζω έχεις αυτό που θέλεις πλέον!