QB64.org Forum

Active Forums => Programs => Topic started by: bplus on September 03, 2021, 12:33:54 am

Title: Wordiff - Rosetta Code
Post by: bplus on September 03, 2021, 12:33:54 am

ref: http://rosettacode.org/wiki/Wordiff

I think I have the game roughed out now and will go for the "Optional Stretch Goals" with the scores array tomorrow. Kind'a fun to play :)

Code: QB64: [Select]

1. _Title "Wordiff - Rosetta Code" 'b+ 2021-09-02 ref: http://rosettacode.org/wiki/Wordiff
2. Const nWords = 24819 ' precounted for  unixdict.txt word list
3. Dim Shared words$(1 To nWords), used$(1 To 1000), nUsed, players$(1 To 100), scores(1 To 100), nPlayers, nextPlayer
4.  
5. LoadWords
6. getPlayers
7. nextPlayer = 1
8.  
9. newRound:
10. lastWord$ = StartWord$
11. Print "Start word is "; lastWord$
12. bad = 0
13. Do
14.     Print players$(nextPlayer);
15.     Input ", please enter your try "; try$
16.     For i = 1 To nUsed
17.         If try$ = used$(i) Then Print "I'm sorry, " + players$(nextPlayer) + ", " + try$ + " was already used.": bad = -1
18.     Next
19.     If bad = 0 Then
20.         If wordFound%(try$) Then
21.             If Len(try$) = Len(lastWord$) - 1 Then
22.                 If oneLess%(lastWord$, try$) Then Print "Good" Else Print try$ + " doesn't work.": bad = -1
23.             ElseIf Len(try$) = Len(lastWord$) Then
24.                 If oneChange%(lastWord$, try$) Then Print "Good" Else Print try$ + " doesn't work.": bad = -1
25.             ElseIf Len(try$) = Len(lastWord$) + 1 Then
26.                 If oneMore%(lastWord$, try$) Then Print "Good" Else Print try$ + " doesn't work.": bad = -1
27.             Else
28.                 Print "I'm sorry, " + players$(nextPlayer) + ", " + try$ + " was not the correct length.": bad = -1
29.             End If
30.         Else
31.             Print "I'm sorry, " + players$(nextPlayer) + ", " + try$ + " was not found in dictionary.": bad = -1
32.         End If
33.     End If
34.     If bad = 0 Then
35.         nUsed = nUsed + 1
36.         used$(nUsed) = try$
37.         lastWord$ = try$
38.     End If
39.     nextPlayer = nextPlayer + 1
40.     If nextPlayer > nPlayers Then nextPlayer = 1
41. Loop Until bad
42. GoTo newRound
43.  
44. Sub LoadWords
45.     Dim wd$, i As Integer, m As Integer, ok As _Bit
46.     Open "unixdict.txt" For Input As #1
47.     While EOF(1) = 0
48.         Input #1, wd$
49.         If Len(wd$) > 2 Then
50.             ok = -1
51.             For m = 1 To Len(wd$)
52.                 If Asc(wd$, m) < 97 Or Asc(wd$, m) > 122 Then ok = 0: Exit For
53.             Next
54.             If ok Then i = i + 1: words$(i) = wd$
55.         End If
56.     Wend
57.     Close #1
58. End Sub
59.  
60. Sub getPlayers
61.     nPlayers = 0
62.     Do
63.         Input "Enter a player name or nothing to finish list "; player$
64.         If player$ <> "" Then nPlayers = nPlayers + 1: players$(nPlayers) = player$
65.     Loop Until player$ = ""
66.     If nPlayers = 0 Then Print "No players, goodbye!"
67. End Sub
68.  
69. Function StartWord$
70.     Do
71.         StartWord$ = words$(Int(Rnd * nWords) + 1)
72.         If Len(StartWord$) > 2 And Len(StartWord$) < 5 Then
73.             OK = -1
74.             For i = 1 To nUsed ' let us at least not start with a word used in last game
75.                 If used$(i) = StartWord$ Then OK = 0
76.             Next
77.         End If
78.         If OK Then Erase used$: nUsed = 1: used$(1) = StartWord$
79.     Loop Until OK
80. End Function
81.  
82. Function wordFound% (word$) ' is the word 3 or more letters in dictionary
83.     If Len(word$) > 2 Then
84.         lo = 1: hi = nWords
85.         Do While wordFound% = 0
86.             test = Int((hi + lo) / 2)
87.             If words$(test) = word$ Then
88.                 wordFound% = -1: Exit Function
89.             ElseIf words$(test) < word$ Then
90.                 lo = test + 1
91.             Else
92.                 hi = test - 1
93.             End If
94.             If hi < lo Then Exit Function
95.         Loop
96.     End If
97. End Function
98.  
99. Function oneLess% (last$, test$) ' is word one letter less than last word
100.     If Len(test$) = Len(last$) - 1 Then
101.         lastfind = 1
102.         For i = 1 To Len(test$)
103.             find = InStr(lastfind, last$, Mid$(test$, i, 1))
104.             If find = 0 Then Exit Function Else lastfind = find + 1
105.         Next
106.         oneLess% = -1
107.     End If
108. End Function
109.  
110. Function oneMore% (last$, test$) ' is word one letter more than last word
111.     If Len(test$) = Len(last$) + 1 Then
112.         lastfind = 1
113.         For i = 1 To Len(last$)
114.             find = InStr(lastfind, test$, Mid$(lasst$, i, 1))
115.             If find = 0 Then Exit Function Else lastfind = find + 1
116.         Next
117.         oneMore% = -1
118.     End If
119. End Function
120.  
121. Function oneChange% (last$, test$)
122.     If Len(test$) = Len(last$) Then
123.         For i = 1 To Len(last$)
124.             If Mid$(last$, i, 1) <> Mid$(test$, i, 1) Then strike = strike + 1
125.         Next
126.         If strike = 1 Then oneChange% = -1
127.     End If
128. End Function
129.  
130.  

Attached is dictionary used at RC (doesn't have "has")

Title: Re: Wordiff - Rosetta Code
Post by: bplus on September 03, 2021, 11:42:29 am

Dang, how is that working with a typo?

Title: Re: Wordiff - Rosetta Code
Post by: bplus on September 03, 2021, 11:52:35 am

It was letting all words the right length to pass.

Code: QB64: [Select]

1. 'test oneMore%
2. Do
3.     Input "Testing oneMore%, enter last word, test word "; last$, test$
4.     If oneMore%(last$, test$) Then Print "One more" Else Print "NOT one more"
5. Loop Until last$ = ""
6. End
7.  
8. Function oneMore% (last$, test$) ' is word one letter more than last word
9.     If Len(test$) = Len(last$) + 1 Then
10.         lastfind = 1
11.         For i = 1 To Len(last$)
12.             find = InStr(lastfind, test$, Mid$(last$, i, 1)) ' typo fix 2021-09-03
13.             If find = 0 Then Exit Function Else lastfind = find + 1
14.         Next
15.         oneMore% = -1
16.     End If
17. End Function
18.  

Title: Re: Wordiff - Rosetta Code
Post by: bplus on September 03, 2021, 01:42:45 pm

Reworked the checking code and added computer finds when a player misses that could have been played off last correct wordiff:

Code: QB64: [Select]

1. _Title "Wordiff - Rosetta Code" 'b+ 2021-09-02 ref: http://rosettacode.org/wiki/Wordiff
2. Randomize Timer
3. Const nWords = 24819 ' precounted for  unixdict.txt word list
4. Dim Shared words$(1 To nWords), used$(1 To 1000), nUsed, players$(1 To 100), nPlayers, nextPlayer
5. Q$(0) = "Good!": Q$(1) = "used already.": Q$(2) = "not in dictionary.": Q$(3) = "bad minus letter."
6. Q$(4) = "bad letter change.": Q$(5) = "bad add letter.": Q$(6) = "bad length."
7. LoadWords
8. getPlayers
9. nextPlayer = 1
10. newRound:
11. lastWord$ = StartWord$
12. Print: Print "Start word is "; lastWord$
13. Do
14.     Print players$(nextPlayer);
15.     Input ", please enter your try "; try$
16.     badtry = bad%(lastWord$, try$)
17.     Print try$ + " is " + Q$(badtry)
18.     If badtry = 0 Then
19.         nUsed = nUsed + 1
20.         used$(nUsed) = try$
21.         lastWord$ = try$
22.     End If
23.     nextPlayer = nextPlayer + 1
24.     If nextPlayer > nPlayers Then nextPlayer = 1
25. Loop Until badtry
26. Print "Wordiffs found for " + lastWord$ + " are:"
27. finds lastWord$
28. GoTo newRound
29.  
30. Sub LoadWords
31.     Dim wd$, i As Integer, m As Integer, ok As _Bit
32.     Open "unixdict.txt" For Input As #1
33.     While EOF(1) = 0
34.         Input #1, wd$
35.         If Len(wd$) > 2 Then
36.             ok = -1
37.             For m = 1 To Len(wd$)
38.                 If Asc(wd$, m) < 97 Or Asc(wd$, m) > 122 Then ok = 0: Exit For
39.             Next
40.             If ok Then i = i + 1: words$(i) = wd$
41.         End If
42.     Wend
43.     Close #1
44. End Sub
45.  
46. Sub getPlayers
47.     nPlayers = 0
48.     Do
49.         Input "Enter a player name or nothing to finish list "; player$
50.         If player$ <> "" Then nPlayers = nPlayers + 1: players$(nPlayers) = player$
51.     Loop Until player$ = ""
52.     If nPlayers = 0 Then Print "No players, goodbye!": End
53. End Sub
54.  
55. Function StartWord$
56.     Do
57.         StartWord$ = words$(Int(Rnd * nWords) + 1)
58.         If Len(StartWord$) > 2 And Len(StartWord$) < 5 Then
59.             OK = -1
60.             For i = 1 To nUsed ' let us at least not start with a word used in last game
61.                 If used$(i) = StartWord$ Then OK = 0
62.             Next
63.         End If
64.         If OK Then Erase used$: nUsed = 1: used$(1) = StartWord$
65.     Loop Until OK
66. End Function
67.  
68. Function wordFound% (word$) ' is the word 3 or more letters in dictionary
69.     If Len(word$) > 2 Then
70.         lo = 1: hi = nWords
71.         Do While wordFound% = 0
72.             test = Int((hi + lo) / 2)
73.             If words$(test) = word$ Then
74.                 wordFound% = -1: Exit Function
75.             ElseIf words$(test) < word$ Then
76.                 lo = test + 1
77.             Else
78.                 hi = test - 1
79.             End If
80.             If hi < lo Then Exit Function
81.         Loop
82.     End If
83. End Function
84.  
85. Function oneLess% (last$, test$) ' is word one letter less than last word
86.     If Len(test$) = Len(last$) - 1 Then
87.         lastfind = 1
88.         For i = 1 To Len(test$)
89.             find = InStr(lastfind, last$, Mid$(test$, i, 1))
90.             If find = 0 Then Exit Function Else lastfind = find + 1
91.         Next
92.         oneLess% = -1
93.     End If
94. End Function
95.  
96. Function oneMore% (last$, test$) ' is word one letter more than last word
97.     If Len(test$) = Len(last$) + 1 Then
98.         lastfind = 1
99.         For i = 1 To Len(last$)
100.             find = InStr(lastfind, test$, Mid$(last$, i, 1)) ' typo fix 2021-09-03
101.             If find = 0 Then Exit Function Else lastfind = find + 1
102.         Next
103.         oneMore% = -1
104.     End If
105. End Function
106.  
107. Function oneChange% (last$, test$)
108.     If Len(test$) = Len(last$) Then
109.         For i = 1 To Len(last$)
110.             If Mid$(last$, i, 1) <> Mid$(test$, i, 1) Then strike = strike + 1
111.         Next
112.         If strike = 1 Then oneChange% = -1
113.     End If
114. End Function
115.  
116. Function bad% (last$, test$)
117.     For i = 1 To nUsed
118.         If test$ = used$(i) Then bad% = 1: Exit Function
119.     Next
120.     If wordFound%(test$) = 0 Then bad% = 2: Exit Function
121.     If Len(test$) = Len(last$) - 1 Then
122.         If oneLess%(last$, test$) = 0 Then bad% = 3
123.     ElseIf Len(test$) = Len(last$) Then
124.         If oneChange%(last$, test$) = 0 Then bad% = 4
125.     ElseIf Len(test$) = Len(last$) + 1 Then
126.         If oneMore%(last$, test$) = 0 Then bad% = 5
127.     Else
128.         bad% = 6
129.     End If
130. End Function
131.  
132. Sub finds (last$) ' find all words that would have worked
133.     For i = 1 To nWords
134.         test$ = words$(i)
135.         For j = 1 To nUsed
136.             If test$ = used$(j) Then GoTo skip '_continue didn't work
137.         Next
138.         If oneLess%(last$, test$) Then Print test$; " ";
139.         If oneChange%(last$, test$) Then Print test$; " ";
140.         If oneMore%(last$, test$) Then Print test$; " ";
141.         skip:
142.     Next
143.     Print
144. End Sub
145.  

Time keeping seems boring and unfair for scoring as words get longer and more difficult, so I took out scores array. Much more interesting to show what could have been played IMHO.

See first post for dictionary file or use your own.

Text Only | Text with Attachments