Author Topic: Rebus of Letters  (Read 10249 times)

0 Members and 1 Guest are viewing this topic.

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Rebus of Letters
« Reply #15 on: September 01, 2020, 09:48:20 am »
Quote
improvement possible: variable number of letters
then nested comparison loops will be universal

Yeah my program writer uses the actual number of letters and the actual letters when it writes the Solver Program to run. Along with the Operation to use: add, subtract, multiple, divide and inputs number of words if it's to be addition.

Bout time I cleaned up the Program Writer and presented it.

Marked as best answer by DANILIN on September 02, 2020, 09:09:37 am

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Rebus of Letters
« Reply #16 on: September 02, 2020, 02:53:10 am »
I found a much easier way to input and process the Cryptarithm Puzzles. We had done these puzzles years ago at JB forum. With JB what you print onto the output screen can be copy and pasted through clipboard so there and then we were outputting programs on screen then copy / pasting as New bas code to run. But hardly any difference between printing to screen and printing to file.

Anyway, I rewrote the Input part of the puzzle and all the ramifications it involved and then rewrote and reran all the solvers. All the .bas files now start with word Solve (the equation).bas as the filename. The ones that have all 10 digits run about 20 minutes and on my CPU I can easily run 3 at a time.

So here is Writer #2:
Code: QB64: [Select]
  1. _TITLE "Cryptarithm Program Writer #2 ASMD" 'b+ 2020-09-01
  2. ' for rebus challenge by danilin ref:  https://www.qb64.org/forum/index.php?topic=2961.msg122153#msg122153
  3. ' Takes input for words to add and solve and writes a program to do that.
  4.  
  5. ' 2020-08-31 Let's "add" more than 2 words -  Cryptarithm Program Writer +.bas
  6. ' write 1 solution because we don't want to run through all 10 digits of 10 letter permutations
  7. ' We probably want the letter of the last word to go first (be the last to change). Done that was easy!
  8. ' No not done we need to make the last word first!
  9.  
  10. ' 2020-08-31 PM Let's do more than just add  -  Cryptarithm Program Writer ASMD.bas
  11. ' Had to add  "_DEFINE A-Z AS _INTEGER64" to programs being written, as one test returned answer
  12. ' with e notation.
  13.  
  14. ' 2020-09-01 Got a huge hint from tsh73 from years ago at JB Forum how to make the input to the
  15. ' Program Writer a one line, simply enter the whole equation. We will use spaces to separate
  16. ' the words from the operators or = sign. Simply smart!
  17.  
  18. SCREEN _NEWIMAGE(1200, 400, 32) 'need a wider screen taller screen for lot's of solutions
  19. _DELAY .25
  20. restart:
  21. PRINT "             For our word equation use the following operator symbols:"
  22. PRINT "  + add, - subtract, * multiply, \ integer divide and = sign with final word"
  23. PRINT "       Make sure there is a space between each word and operator or = sign."
  24. PRINT "                        Example > hip * hip = hurray"
  25. PRINT "                   No more than 10 different letters total."
  26. LINE INPUT " > "; eq$
  27.  
  28. ' debug with this old one from JB
  29. 'eq$ = "noon + moon + soon = june"
  30.  
  31. REDIM word(0) AS STRING
  32. Split eq$, " ", word()
  33. nWords = UBOUND(word)
  34. list$ = "": start$ = ""
  35. ' collect and count letters
  36. FOR w = nWords TO 0 STEP -2 'make sure first letter of = word is at top of list 10 permutations take while
  37.     FOR i = 1 TO LEN(word(w))
  38.         L$ = MID$(word(w), i, 1)
  39.         IF i = 1 THEN start$ = L$ + start$: wordCnt = wordCnt + 1 ' make sure the first letter of the last word is listed first, never used wordCnt
  40.         addit = -1
  41.         FOR j = 1 TO LEN(list$)
  42.             IF L$ = MID$(list$, j, 1) THEN addit = 0
  43.         NEXT
  44.         IF addit THEN list$ = list$ + L$
  45.     NEXT
  46. PRINT "Letter list, length, start$, eq$: "; list$, LEN(list$), start$, eq$
  47. LL = LEN(list$)
  48. INPUT " Enter anything to quit, just enter to continue..."; quit$
  49. IF LEN(quit$) THEN END
  50.  
  51. 'OK here we start writing the file
  52. p = INSTR(eq$, "\") 'cant open file with "\" in title
  53.     eqq$ = MID$(eq$, 1, p - 1) + "idvd" + MID$(eq$, p + 1)
  54.     eqq$ = eq$
  55. p = INSTR(eqq$, "*") 'cant open file with "*" in title
  56.     eqq$ = MID$(eqq$, 1, p - 1) + "mult" + MID$(eqq$, p + 1)
  57.  
  58. OPEN "Solve (" + eqq$ + ").bas" FOR OUTPUT AS #1
  59. S1$ = " ' written by Cryptarithm Program Writer #2 ASMD.bas b+ 2020-09-01"
  60. PRINT #1, "_TITLE " + CHR$(34) + "Solve (" + eq$ + ").bas" + CHR$(34) + S1$
  61. PRINT #1, "SCREEN _NEWIMAGE(1200, 720, 32) 'need a wider screen taller screen for lot's of solutions"
  62. PRINT #1, "_DELAY .25"
  63. PRINT #1, "_SCREENMOVE _MIDDLE"
  64. PRINT #1, "_DEFINE A-Z AS _INTEGER64"
  65. PRINT #1, "DIM a(" + _TRIM$(STR$(LL)) + ")"
  66.  
  67. S$ = "" ' Header for solution columns, aint we full of hope!
  68. FOR i = 0 TO nWords STEP 2 ' setup a header actually should do this at start reguardless of solutions or not
  69.     IF i = 0 THEN
  70.         S$ = S$ + CHR$(34) + " " + word(i) + CHR$(34)
  71.     ELSE
  72.         S$ = S$ + CHR$(34) + word(i - 1) + word(i) + CHR$(34)
  73.     END IF
  74.     IF i <> nWords THEN S$ = S$ + ", "
  75. Header$ = S$ ' if there are allot of multiple solutions the we could pause, then cls and fill another with header
  76. PRINT #1, "PRINT " + S$
  77.  
  78. FOR i = 1 TO LEN(list$)
  79.     IF INSTR(start$, MID$(list$, i, 1)) THEN
  80.         PRINT #1, "FOR " + MID$(list$, i, 1) + " = 1 to 9: a(" + _TRIM$(STR$(i)) + ") = " + MID$(list$, i, 1)
  81.     ELSE
  82.         PRINT #1, "FOR " + MID$(list$, i, 1) + " = 0 to 9: a(" + _TRIM$(STR$(i)) + ") = " + MID$(list$, i, 1)
  83.     END IF
  84.  
  85. PRINT #1, "FOR xx = 1 TO " + _TRIM$(STR$(LL - 1))
  86. PRINT #1, "FOR yy = xx + 1 TO " + _TRIM$(STR$(LL))
  87. PRINT #1, "IF a(xx) = a(yy) THEN GOTO skip"
  88. PRINT #1, "NEXT"
  89. PRINT #1, "NEXT"
  90.  
  91. 'ten = 100 * t + 10 * e + n
  92. FOR w = 0 TO nWords STEP 2
  93.     S$ = word(w) + " = "
  94.     LW = LEN(word(w))
  95.     FOR i = 1 TO LW
  96.         S$ = S$ + "10 ^ " + _TRIM$(STR$(LW - i)) + " * " + MID$(word(w), i, 1)
  97.         IF i <> LW THEN S$ = S$ + " + "
  98.     NEXT
  99.     PRINT #1, S$
  100.  
  101. 'IF ten + two = four THEN
  102. PRINT #1, "IF " + eq$ + " THEN" '  here we have a solution
  103.  
  104. 'PRINT count, ten, two, four
  105. S$ = ""
  106. FOR i = 0 TO nWords STEP 2
  107.     S$ = S$ + word(i)
  108.     IF i <> nWords THEN S$ = S$ + ", "
  109. PRINT #1, "PRINT " + S$
  110. 'PRINT #1, "PRINT: PRINT " + CHR$(34) + "  Press any to end..." + CHR$(34)
  111. 'PRINT #1, "SLEEP"
  112. 'PRINT #1, "END"
  113. PRINT #1, "END IF"
  114.  
  115. PRINT #1, "skip:"
  116. FOR i = 1 TO LL
  117.     PRINT #1, "NEXT"
  118. PRINT #1, "PRINT " + CHR$(34) + " Run is done, goodbye!" + CHR$(34)
  119. PRINT "File Ready"
  120. GOTO restart
  121.  
  122. SUB Split (SplitMeString AS STRING, delim AS STRING, loadMeArray() AS STRING)
  123.     DIM curpos AS LONG, arrpos AS LONG, LD AS LONG, dpos AS LONG 'fix use the Lbound the array already has
  124.     curpos = 1: arrpos = LBOUND(loadMeArray): LD = LEN(delim)
  125.     dpos = INSTR(curpos, SplitMeString, delim)
  126.     DO UNTIL dpos = 0
  127.         loadMeArray(arrpos) = MID$(SplitMeString, curpos, dpos - curpos)
  128.         arrpos = arrpos + 1
  129.         IF arrpos > UBOUND(loadMeArray) THEN REDIM _PRESERVE loadMeArray(LBOUND(loadMeArray) TO UBOUND(loadMeArray) + 1000) AS STRING
  130.         curpos = dpos + LD
  131.         dpos = INSTR(curpos, SplitMeString, delim)
  132.     LOOP
  133.     loadMeArray(arrpos) = MID$(SplitMeString, curpos)
  134.     REDIM _PRESERVE loadMeArray(LBOUND(loadMeArray) TO arrpos) AS STRING 'get the ubound correct
  135.  
  136.  

and here is the load of Solvers I've written with it tonight, a couple of subtraction, division and multiplication but mostly addition of two or more words:
* Cryptarithm Program Writer #2.zip (Filesize: 13.64 KB, Downloads: 229)
« Last Edit: September 02, 2020, 03:04:16 am by bplus »

Offline DANILIN

  • Forum Regular
  • Posts: 128
    • View Profile
    • Danilin youtube
Re: Rebus of Letters
« Reply #17 on: September 03, 2020, 02:04:37 am »
Brilliant work synthesizing programs from a program

I remembered doing the same thing in Excel for an idea
Quadrat Economy Danilins
where regular changes in the code are made in Excel

 
excelbas2.PNG


And without Excel and without synthesis it takes into account 10 letters
there are probably "IF" before cycles

Original code:
Code: QB64: [Select]
  1. ' Russian Rebus of Letters from Digitals.bas
  2. NN = 5: DIM a(NN)
  3. FOR u = 1 TO 9: a(1) = u
  4.     FOR d = 1 TO 9: a(2) = d
  5.         FOR a = 0 TO 9: a(3) = a
  6.             FOR r = 0 TO 9: a(4) = r
  7.                 FOR k = 0 TO 9: a(5) = k
  8. FOR xx = 1 TO NN-1
  9.    FOR yy = xx + 1 TO NN
  10.       IF a(xx) = a(yy) THEN GOTO 55
  11. NEXT yy: NEXT xx
  12.              udar = 1000*u + 100*d + 10*a + r
  13.              draka = d*10000 + r*1000 + a*100 + k*10 + a
  14.                   IF udar + udar = draka THEN PRINT udar, draka
« Last Edit: September 05, 2020, 04:50:24 am by DANILIN »
Russia looks world from future. big data is peace data.
https://youtube.com/playlist?list=PLBBTP9oVY7IagpH0g9FNUQ8JqmHwxDDDB
i never recommend anything to anyone and always write only about myself

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Rebus of Letters
« Reply #18 on: September 05, 2020, 01:31:30 pm »
Yes, your example for handling IF's was very helpful. I was prepared to systematically run through the combinations.

Offline TempodiBasic

  • Forum Resident
  • Posts: 1792
    • View Profile
Re: Rebus of Letters
« Reply #19 on: September 06, 2020, 08:17:32 pm »
Hi Bplus and DANILIN

so I can see that you like the crytography and the use of brute force of  PC machine to solve it.

Do you think that it is possible to apply this method for solve the Lettera del Diavolo di Agrigento (Letter of devil that stays in Agrigento)?
here a link to the issuehttps://sites.google.com/site/beatacorbera/lettera-del-diavolo and the letter https://sites.google.com/site/beatacorbera/_/rsrc/1317142844724/lettera-del-diavolo/LETTERA%20DEL%20DIAVOLO.jpg?height=1553&width=1118

Thanks to read
Programming isn't difficult, only it's  consuming time and coffee

Offline DANILIN

  • Forum Regular
  • Posts: 128
    • View Profile
    • Danilin youtube
Re: Rebus of Letters
« Reply #20 on: September 07, 2020, 08:40:26 am »
Theoretically without a key except for letter differences
this algorithm compares letters with each other
requires up to 26*25/2=325 comparisons each turn
and it will give out words from different letters

And one day this text will add up to a readable one

Code: QB64: [Select]
  1. NN = 26: DIM a(NN)
  2. FOR a = 1 TO 26: a(1) = a
  3.     FOR b = 1 TO 26: a(2) = b
  4.         ...
  5.             FOR y = 1 TO 26: a(25) = y
  6.                 FOR z = 1 TO 26: a(26) = z
  7. FOR xx = 1 TO NN-1: FOR yy = xx+1 TO NN
  8.       IF a(xx) = a(yy) THEN GOTO 55
  9. NEXT yy: NEXT xx

Then output prepared letter combination
main thing is that order is observed

I'll check it out for myself:

Code: QB64: [Select]
  1. NN = 5: DIM a(NN): s = 0 ' danilin.bas
  2. FOR d = 0 TO 26: a(1) = d
  3.     FOR a = 0 TO 26: a(2) = a
  4.         FOR n = 0 TO 26: a(3) = n
  5.             FOR i = 0 TO 26: a(4) = i
  6.                 FOR l = 0 TO 26: a(5) = l
  7.     FOR xx = 1 TO NN - 1: FOR yy = xx+1 TO NN
  8.           IF a(xx) = a(yy) THEN GOTO 55
  9.     NEXT yy: NEXT xx
  10. s = s+1
  11. Word$ = CHR$(65+a(1)) + CHR$(65+a(2)) + CHR$(65+a(3)) + CHR$(65+a(4)) + CHR$(65+a(5)) + CHR$(65+a(4)) + CHR$(65+a(3))
  12. PRINT s; Word$;
  13. IF Word$ = "DANILIN" THEN END
  14.  

DANILIN # 1'082'619 by 5 seconds
« Last Edit: September 07, 2020, 09:57:33 am by DANILIN »
Russia looks world from future. big data is peace data.
https://youtube.com/playlist?list=PLBBTP9oVY7IagpH0g9FNUQ8JqmHwxDDDB
i never recommend anything to anyone and always write only about myself

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Rebus of Letters
« Reply #21 on: September 07, 2020, 12:47:01 pm »
Hey @TempodiBasic

I don't consider these Solvers = cryptography, they are letter/word equations/puzzles to be solved besides, some of them have more than one solution.

Any cryptography of worth would not repeat the same value for same letter, too easy!
« Last Edit: September 07, 2020, 02:12:58 pm by bplus »

Offline TempodiBasic

  • Forum Resident
  • Posts: 1792
    • View Profile
Re: Rebus of Letters
« Reply #22 on: September 07, 2020, 05:50:29 pm »
@bplus
before to run you must be able to walk, and before to walk you must be able to stand on your feet...

Yes the scrolling frame is the second pattern used into cryptography after the substitution one to one from a symbol to another of another kind. The third step, generally, is the substitution one symbol to many symbol following a math scheme.
Here I post an example of the easyest cryptography  taken from this link https://www.google.com/url?sa=i&url=https%3A%2F%2Fpdfslide.net%2Fdocuments%2Fsettimana-enigmistica-3270-con-soluzioni.html&psig=AOvVaw1YIuX2pFgB3ItXqzNONtDT&ust=1599600916868000&source=images&cd=vfe&ved=0CA4QtaYDahcKEwjQ0JL3_9frAhUAAAAAHQAAAAAQCw

Quote
L'ANEDDOTO CIFRATO
123456-78-9
8 IO 9 3 Il 2 - IO 8 12
13 2 Il Brando 8 14 6 14 8
13 - 8 9 3 15 16 7 3 Il
6 7 3 - 8 Il 7 8 12 17
6 Il 6 - 8 - 18 2 Il 18
2 invece 7 3 - 12 6 4 8 12
17 3 - 8 - 17 4 16 2 13
8 . - 13 8 - 17 2 12 6 13
13 8 - IO 8 19 19 3 2 12
6 - 7 6 4 3 17 6 - 3 Il
20 3 Il 6 - 7 3 accompagnar­
velo I 6 12 17 2 Il 8 13 IO
6 Il 15 6 • - 15 6 Il 6 Il
7 2 13 2 - 8 13 - 19 16
3 Il 18 8 19 13 3 2 .
Sostituite una lettera ad ogni numero.
Good Luck to translate into italian language. (using a foreign language to write the message: this can be another way to make more difficult the cryptography because everyone is used to think and talk in own native language and not in other languages.)

Programming isn't difficult, only it's  consuming time and coffee

Offline DANILIN

  • Forum Regular
  • Posts: 128
    • View Profile
    • Danilin youtube
Re: Rebus of Letters
« Reply #23 on: September 08, 2020, 06:58:53 am »
Program lists combinations of 7 letters
before word ZYXWVUT
reporting results every 15 seconds
practically changing 2nd letter
and it takes about 3 hours for all iterations
Code: QB64: [Select]
  1. start = TIMER: NN = 7: t = 0: DIM a(NN): DIM s AS DOUBLE: s = 0:' zyxwvut.bas
  2. FOR a = 0 TO 25: a(1) = a
  3.     FOR b = 0 TO 25: a(2) = b
  4.         FOR c = 0 TO 25: a(3) = c
  5.             FOR d = 0 TO 25: a(4) = d
  6.                 FOR e = 0 TO 25: a(5) = e
  7.                     FOR f = 0 TO 25: a(6) = f
  8.                         FOR g = 0 TO 25: a(7) = g
  9.     FOR xx = 1 TO NN - 1: FOR yy = xx + 1 TO NN: IF a(xx) = a(yy) THEN GOTO 55
  10.     NEXT yy: NEXT xx
  11. s = s + 1: finish = TIMER: q = INT(finish - start)
  12. Word$ = CHR$(65+a(1)) + CHR$(65+a(2)) + CHR$(65+a(3)) + CHR$(65+a(4)) + CHR$(65+a(5)) + CHR$(65+a(6)) + CHR$(65+a(7))
  13. IF q-t = 15 THEN PRINT q; "s. "; INT(s /10^6); "mln. "; Word$; ,: t = q
  14. IF Word$ = "ZYXWVUT" THEN PRINT s; Word$; ,: finish = TIMER: PRINT finish - start: END
  15.    55 NEXT: NEXT: NEXT: NEXT: NEXT: NEXT: NEXT
  16. finish = TIMER: PRINT finish - start: END

+ 9\9\20

Code: QB64: [Select]
  1. start = TIMER: NN = 7: t = 0: DIM a(NN): DIM s AS DOUBLE: s = 0 ' zyxwvut.bas
  2. FOR a = 25 TO 25: a(1) = a
  3.     FOR b = 24 TO 25: a(2) = b
  4.         FOR c = 0 TO 25: a(3) = c
  5.             FOR d = 0 TO 25: a(4) = d
  6.                 FOR e = 0 TO 25: a(5) = e
  7.                     FOR f = 0 TO 25: a(6) = f
  8.                         FOR g = 0 TO 25: a(7) = g
  9. FOR xx = 1 TO NN - 1: FOR yy = xx + 1 TO NN: IF a(xx) = a(yy) THEN 55
  10.          NEXT yy: NEXT xx: s = s + 1
  11. Word$ = CHR$(65+a(1)) + CHR$(65+a(2)) + CHR$(65+a(3)) + CHR$(65+a(4)) + CHR$(65+a(5)) + CHR$(65+a(6)) + CHR$(65+a(7))
  12. IF Word$ = "ZYXWVUT" THEN 77
  13.   55 NEXT: NEXT: NEXT: NEXT
  14.       PRINT INT(s/10^6); "mln. "; Word$; ,
  15. 77 PRINT s; Word$; ,: finish = TIMER: PRINT finish - start: END

 
33333.PNG


Below: all combination of 7 digital is factorial 7! = 1*2*3*4*5*6*7 = 5040
« Last Edit: September 08, 2020, 06:34:35 pm by DANILIN »
Russia looks world from future. big data is peace data.
https://youtube.com/playlist?list=PLBBTP9oVY7IagpH0g9FNUQ8JqmHwxDDDB
i never recommend anything to anyone and always write only about myself

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Rebus of Letters
« Reply #24 on: September 08, 2020, 12:16:44 pm »
Program lists combinations of 7 letters
before word ZYXWVUT
reporting results every 15 seconds
practically changing 2nd letter
and it takes about 3 hours for all iterations
Code: QB64: [Select]
  1. start = TIMER: NN = 7: t = 0: DIM a(NN): DIM s AS DOUBLE: s = 0:' zyxwvut.bas
  2. FOR a = 0 TO 25: a(1) = a
  3.     FOR b = 0 TO 25: a(2) = b
  4.         FOR c = 0 TO 25: a(3) = c
  5.             FOR d = 0 TO 25: a(4) = d
  6.                 FOR e = 0 TO 25: a(5) = e
  7.                     FOR f = 0 TO 25: a(6) = f
  8.                         FOR g = 0 TO 25: a(7) = g
  9.     FOR xx = 1 TO NN - 1: FOR yy = xx + 1 TO NN: IF a(xx) = a(yy) THEN GOTO 55
  10.     NEXT yy: NEXT xx
  11. s = s + 1: finish = TIMER: q = INT(finish - start)
  12. Word$ = CHR$(65+a(1)) + CHR$(65+a(2)) + CHR$(65+a(3)) + CHR$(65+a(4)) + CHR$(65+a(5)) + CHR$(65+a(6)) + CHR$(65+a(7))
  13. IF q-t = 15 THEN PRINT q; "s. "; INT(s /10^6); "mln. "; Word$; ,: t = q
  14. IF Word$ = "ZYXWVUT" THEN PRINT s; Word$; ,: finish = TIMER: PRINT finish - start: END
  15.    55 NEXT: NEXT: NEXT: NEXT: NEXT: NEXT: NEXT
  16. finish = TIMER: PRINT finish - start: END


@DANILIN  sorry this does not make sense to me maybe I miss something or something lost in translation but
there is 1 combination of 7 letters using all 7 letters
and there are 2^7 sets of combination subsets of a 7 element set including the combination of no letters.

There are 7! Permutations of 7 letters that is only 5040 which should take less than a minute to generate even on slow computer.

Lets see if I can dig up the code that will list perms of abcdefg

Ah here we go! 5040 permutations. This thing can do whole words too!
Code: QB64: [Select]
  1. _TITLE "Permutations with value translator" 'B+ add value translator 2019-03-31
  2. 'from "Permutations wo recursion"  translate from SmallBasic to QB64 2019-03-31
  3. 'from "Permutations" translation from: PowerBASIC, tsh copy from Liberty link 2017-02-04
  4.  
  5. SCREEN _NEWIMAGE(800, 600, 32)
  6. _SCREENMOVE 300, 40
  7.  
  8. REDIM results$(0)
  9. loadPermsValues results$()
  10. 'display result$
  11. FOR i = 0 TO UBOUND(results$)
  12.     PRINT i + 1, results$(i)
  13.     IF i MOD 30 = 29 THEN
  14.         PRINT "press any to continue..."
  15.         SLEEP
  16.         CLS
  17.     END IF
  18.  
  19. ValuesData:
  20. DATA "a","b","c","d","e","f","g","END"
  21.  
  22. 'this reads data from ValuesData line and translates Permutations to those values
  23. SUB loadPermsValues (r() AS STRING)
  24.     'load values array one way or another? read data
  25.     REDIM values(0) AS STRING
  26.     RESTORE ValuesData
  27.     DO
  28.         READ r$
  29.         IF r$ = "END" THEN
  30.             done = 1
  31.         ELSE
  32.             n = n + 1
  33.             REDIM _PRESERVE values(n) AS STRING
  34.             values(n) = r$
  35.         END IF
  36.     LOOP UNTIL done
  37.     n = UBOUND(values)
  38.     DIM a(0 TO n + 1) '+1 needed due to bug in LB that checks loop condition: until (i=0) or (a(i)<a(i+1))
  39.     FOR i = 0 TO n: a(i) = i: NEXT 'load a() with minimum values
  40.     DO
  41.         b$ = ""
  42.         FOR i = 1 TO n
  43.             b$ = b$ + values(a(i)) + " "
  44.         NEXT
  45.         REDIM _PRESERVE r(e)
  46.         r(e) = b$
  47.         e = e + 1
  48.  
  49.         i = n
  50.         DO
  51.             i = i - 1
  52.         LOOP UNTIL (i = 0) OR (a(i) < a(i + 1))
  53.         j = i + 1
  54.         k = n
  55.         WHILE j < k
  56.             SWAP a(j), a(k)
  57.             j = j + 1
  58.             k = k - 1
  59.         WEND
  60.         IF i > 0 THEN
  61.             j = i + 1
  62.             WHILE a(j) < a(i)
  63.                 j = j + 1
  64.             WEND
  65.             SWAP a(i), a(j)
  66.         END IF
  67.     LOOP UNTIL i = 0
  68.     EXIT SUB
  69.  
  70.  
« Last Edit: September 08, 2020, 12:20:31 pm by bplus »

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Rebus of Letters
« Reply #25 on: September 08, 2020, 12:28:37 pm »
And for combinations here is how Steve handled the listing of Combinations of 60 numbers taken 6 at a time:

Code: QB64: [Select]
  1. ' print ordered list of combo rCn, r = 6 n = 60 Steve McNeill 2019-03-28
  2.  
  3. PRINT "Calculating..."
  4. OPEN "6 Combos from 60 Numbers.txt" FOR OUTPUT AS #1
  5. FOR num1 = 1 TO 55
  6.     LOCATE 2, 1: PRINT num1,
  7.     FOR num2 = num1 + 1 TO 56
  8.         LOCATE 3, 1: PRINT num2,
  9.         FOR num3 = num2 + 1 TO 57
  10.             LOCATE 4, 1: PRINT num3,
  11.             FOR num4 = num3 + 1 TO 58
  12.                 LOCATE 5, 1: PRINT num4,
  13.                 FOR num5 = num4 + 1 TO 59
  14.                     LOCATE 6, 1: PRINT num5,
  15.                     FOR num6 = num5 + 1 TO 60
  16.                         LOCATE 7, 1: PRINT num6
  17.                         s$ = LTRIM$(STR$(num1)) + ","
  18.                         IF num1 < 10 THEN s$ = "0" + s$
  19.                         IF num2 < 10 THEN s$ = s$ + "0"
  20.                         s$ = s$ + LTRIM$(STR$(num2)) + ","
  21.                         IF num3 < 10 THEN s$ = s$ + "0"
  22.                         s$ = s$ + LTRIM$(STR$(num3)) + ","
  23.                         IF num4 < 10 THEN s$ = s$ + "0"
  24.                         s$ = s$ + LTRIM$(STR$(num4)) + ","
  25.                         IF num5 < 10 THEN s$ = s$ + "0"
  26.                         s$ = s$ + LTRIM$(STR$(num5)) + ","
  27.                         IF num6 < 10 THEN s$ = s$ + "0"
  28.                         s$ = s$ + LTRIM$(STR$(num6))
  29.                         PRINT #1, s$
  30.                     NEXT
  31.                 NEXT
  32.             NEXT
  33.         NEXT
  34.     NEXT
  35.  
  36.  

Now I will make a program to generate all the combinations of an n element set because I've been meaning to do that :)

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Rebus of Letters
« Reply #26 on: September 08, 2020, 02:12:35 pm »
Sometimes I impress myself:
Ordered Combinations Generator (using letters to represent elements in a set)
https://www.qb64.org/forum/index.php?topic=2999.msg122579#msg122579
« Last Edit: September 08, 2020, 02:13:56 pm by bplus »