ALGORITHMEN - Teil XVII: Im Gruselkeller der Hirnwindungen

    Diese Seite verwendet Cookies. Durch die Nutzung unserer Seite erklären Sie sich damit einverstanden, dass wir Cookies setzen. Weitere Informationen

    Unsere Datenschutzerklärung wurde aktualisiert. Mit der Nutzung unseres Forums akzeptierst Du unsere Datenschutzerklärung. Du bestätigst zudem, dass Du mindestens 16 Jahre alt bist.

    • Neu

      Abt. Rekursion mit XProfan
      ===================
      Rekursion ist an sich keine Stärke von XProfan. Der bekannte "Fluch der Dimensionen" schlägt daher relativ früh zu: Bei Wortkettenbildung z.B. (Letzter Buchstabe = erster Buchstabe des Folgewortes) aus einem "Wortschatz" von max. 70 Wörtern wird das Endziel (23 Wörter in der Kette) erst nach etwa 2 Stunden Rechenzeit erreicht - ein Geduldspiel, aber immerhin: Es geht!
      Für praktische Zwecke - eine ähnliche Aufgabe wäre z.B. Maschinenpark-Durchlaufzeitoptimierung ("Job-Shop-Problem") - wäre eine deutliche Beschleunigung z.B. per Assembler wünschenswert. Anbei ein paar Benchmarks.
      Gruss

      Tabelle "Komplexität vs. Rechenzeit"
      -----------------------------------------------
      Zu prüfender Wortschatz | Rechenzeit:
      47 Worte von max. 70: <0.5 Sekunden
      48: ~1 Sek.
      49: 6 Sek.
      50: 12 s (Interpreter ca. 1 min)
      51: 13 s
      52: 43 s (... eigenartiger Sprung! Auslagerungsdatei?)
      53: 47 s
      54: 60 Sekunden = 1 min
      55: 154 Sekunden = 1.5 min
      56: 163 sek = 2.7 min
      57: 172 sek = 2.8 min
      58: 372 sek = 6.2 min
      59: 338 s = 5.7 min (Eigenartig: Memoryverwaltung scheint zu optimieren.
      Von Datenanordnung abhängigies Teilergebnis: Max. Kettenlänge 20, kommt hier 80 mal vor)
      60: 366 s = 6.1 min
      61: 1747 s 22 lang (460 mal) 29.5 min (nächster eigenartiger Sprung!)
      62: 1773 s exe 22 (461) = 29.55 min
      63: 2017 s exe 22 (416) = 33.62 min
      64: 2300 s exe 22 (416) ? 38.33 min (bis hier am Laptop getestet)
      ...
      70: ~7200 sek = 120 min = Vermutlich ~ 2 Std ??

      Brainfuck-Quellcode

      1. WindowTitle upper$(" Last_Letter = First_Letter-Spiel: Längste Wortkette bilden")
      2. '(CL) 2018-08 von BBC-Basic nach XProfan11.2a by P.Specht, Vienna/EU
      3. ' OHNE JEDWEDE GEWÄHR! Without any warranty whatsoever! Rechte Dritter nicht geprüft!
      4. 'REKURSIVER CODE! Q: http://rosettacode.org/wiki/Last_letter-first_letter
      5. WindowStyle 24:CLS:font 1:var Pokemon$=\
      6. "audino bagon baltoy banette bidoof braviary bronzor carracosta charmeleon "+\
      7. "cresselia croagunk darmanitan deino emboar emolga exeggcute gabite "+\
      8. "girafarig gulpin haxorus heatmor heatran ivysaur jellicent jumpluff kangaskhan "+\
      9. "kricketune landorus ledyba loudred lumineon lunatone machamp magnezone mamoswine "+\
      10. "nosepass petilil pidgeotto pikachu pinsir poliwrath poochyena porygon2 "+\
      11. "porygonz registeel relicanth remoraid rufflet sableye scolipede scrafty seaking "+\
      12. "sealeo silcoon simisear snivy snorlax spoink starly tirtouga trapinch treecko "+\
      13. "tyrogue vigoroth vulpix wailord wartortle whismur wingull yamask"
      14. declare i%,w$,n&,Names$[]:Names$[]=explode(Pokemon$," ")
      15. print "\nZUR AUSWAHL STEHEN HIER DIE POKEMONS: ";Pokemon$
      16. print "\n Auswahlgroesse N [n=35..70 > ~ 2h prc-Zeit] = ";:input n&:print
      17. case n&=0:n&=sizeof(Names$[])
      18. print " ";n&;"/70: "; 'Rechenzeit für Test verkürzen durch Kürzung der Auswahl
      19. var TM&=&GetTickCount
      20. var maxPathLength% = 0
      21. var maxPathLengthCount% = 0
      22. var maxPathExample$ = ""
      23. whileloop 0,n&-1:i%=&Loop
      24. w$=names$[0]:names$[0]=names$[i%]:names$[i%]=w$
      25. PROClastfirst(names$[],1)
      26. w$=names$[0]:names$[0]=names$[i%]:names$[i%]=w$
      27. endwhile
      28. PRINT " ERGEBNIS:\n Kettenlaenge [Worte] = ";maxPathLength%
      29. Print " Ermittelt in ";int((&gettickcount-tm&)/1000);" Sekunden"
      30. PRINT " Anzahl Loesungen mit dieser Laenge = ";maxPathLengthCount%
      31. PRINT " Loesungsbeispiel (auch in Zwischenablage): \n\n ";maxPathExample$
      32. clearclip:putclip maxPathExample$
      33. beep:Waitinput
      34. END
      35. Proc PROClastfirst :parameters names$[],offset%
      36. declare L%,i%
      37. IF offset% > maxPathLength%
      38. maxPathLength% = offset%
      39. maxPathLengthCount% = 1
      40. ELSEIF offset% = maxPathLength%
      41. inc maxPathLengthCount%
      42. maxPathExample$ = ""
      43. whileloop 0,offset%-1
      44. maxPathExample$ = maxPathExample$ +names$[&Loop]+"\n "
      45. endwhile
      46. ENDIF
      47. L%=ord(RIGHT$(names$[offset%-1],1))
      48. Whileloop offset%,n&-1:i%=&Loop
      49. IF ord(names$[i%]) = L%
      50. w$=names$[i%]:names$[i%]=names$[offset%]:names$[offset%]=w$
      51. PROClastfirst(names$[], offset%+1)
      52. w$=names$[i%]:names$[i%]=names$[offset%]:names$[offset%]=w$
      53. ENDIF
      54. Endwhile
      55. ENDPROC
      56. 'Originalergebnis:
      57. '-----------------
      58. 'Maximum length = 23; Number of solutions with that length = 1248
      59. 'One such solution:
      60. ' machamp pinsir rufflet trapinch heatmor remoraid darmanitan nosepass
      61. ' starly yamask kricketune exeggcute emboar relicanth haxorus simisear
      62. ' registeel landorus seaking girafarig gabite emolga audino
      Alles anzeigen
      P.S.: Lt. Musterergebnis sollte bei N&=70 Länge 23 herauskommen, Details siehe Programmtext
    • Neu

      Linkempfehlung: Softwarefehler in der Raumfahrt (Youtube)
      ==========

      Nachtrag zum vorigen Beitrag:
      -------------------------------
      70/70 benötigt 2 h 40 min. Ergebnis ist korrekt: Maximallänge = 23:

      machamp pinsir rufflet trapinch heatmor remoraid darmanitan
      nosepass starly yamask kricketune exeggcute emboar relicanth
      haxorus simisear registeel landorus seaking girafarig gabite
      emolga audino.

      Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von p. specht ()

    • Neu

      Abt. Bits zählen
      ==========
      Als Voraussetzung für Codes, die besonders zur Datenübertragung über schlechte oder gestörte Übertragungskanäle geeignet sind (sog. Hamming-Codes, etwa vom Mars-Orbiter zur Erde) ist es wichtig, die Anzahl von ´1´- und ´0´-Bits in einem Datenblock zu kennen. Man benötigt also eine Funktion, die möglichst schnell diei Anzahl der Einsen in einem Byte, Word, DoubleWord (ab XProfan-X1 auch Quadwords = 8 Byte Integers) ermitteln kann. Da gibt es zahlreiche Tricks und Algorithmen, wie das nachstehende Progi zeigt.
      Gruss

      Quellcode

      1. WindowTitle upper$("HAMMING-GEWICHTUNG a.k.a. PopCount( ) der ´1´-bits")
      2. // (D) Demo only, übersetzt 2018-08 by P.Specht, Vienna/EU
      3. // No warranty whatsoever! Ohne jede Garantie! Rechte Dritter ungeprüft!
      4. // Quelle http;//rosettacode.org/wiki/Population_count
      5. // C-Source https;//en.wikipedia.org/wiki/Hamming_weight
      6. '********************************************************************
      7. var x2&=%11000000000100000100000000000011 // <<< CHANGE THIS VALUE
      8. '********************************************************************
      9. CLS:font 2
      10. print "\n TESTWERTE: "
      11. // Limitations test vars:
      12. var x0&=%11111111111111111111111111111111
      13. var x1&=%00000000000000000000000000000000
      14. // Types and constants used in the functions below.
      15. // uint64_t is an unsigned 64-bit integer variable type (in C99 version of C )
      16. // Here (XProfan 11.2a) sInt32 are treated as uInt32
      17. DEF &m1 $55555555 //binary 0101...
      18. DEF &m2 $33333333 //binary 00110011..
      19. DEF &m4 $0f0f0f0f //binary 4 zeros, 4 ones ...
      20. DEF &m8 $00ff00ff //binary 8 zeros, 8 ones ...
      21. DEF &m16 $0000ffff //binary 16 zeros, 16 ones ...
      22. DEF &m32 $00000000 //binary 32 zeros, 32 ones
      23. DEF &hff $ffffffff //binary all ones
      24. DEF &h01 $01010101 //the sum of 256 to the power of 0,1,2,3...
      25. // MAIN
      26. print "\n ";NaivePopCount(x0&),NaivePopCount(x1&),NaivePopCount(x2&)
      27. print "\n ";popcount32a(x0&),popcount32a(x1&),popcount32a(x2&)
      28. print "\n ";popcount32b(x0&),popcount32b(x1&),popcount32b(x2&)
      29. print "\n ";popcount32c(x0&),popcount32c(x1&),popcount32c(x2&)
      30. print "\n ";popcount_d(x0&),popcount_d(x1&),popcount_d(x2&)
      31. print "\n Initializing 65536 Elements of Lookup Table ... (Just a moment, please!)"
      32. Declare Wordbits&[65535]
      33. popcount32e_init
      34. sound 2000,40:locate %csrlin-1,1
      35. print " OK. "
      36. print "\n ";popcount32e(x0&),popcount32e(x1&),popcount32e(x2&)
      37. print "\n\n --- ENDE ---"
      38. waitinput 20000
      39. END //
      40. Proc NaivePopCount :parameters x&
      41. var n&=x& & 1
      42. whileloop 31
      43. x&=x&>>1
      44. case x& & 1:inc n&
      45. endwhile
      46. return n&
      47. endproc
      48. Proc popcount32a :parameters x&
      49. // Simple implementation, uses 24 arithmetic operations (shift, add, and).
      50. x&=(x& & &m1)+((x&>>1) & &m1) //put count of each 2 bits into those 2 bits
      51. x&=(x& & &m2)+((x&>>2) & &m2) //put count of each 4 bits into those 4 bits
      52. x&=(x& & &m4)+((x&>>4) & &m4) //put count of each 8 bits into those 8 bits
      53. x&=(x& & &m8)+((x&>>8) & &m8) //put count of each 16 bits into those 16 bits
      54. x&=(x& & &m16)+((x&>>16) & &m16) //put count of each 32 bits into those 32 bits; End for 32-bit
      55. 'x&=(x& & &m32)+((x&>>32) & &m32) //put count of each 64 bits into those 64 bits
      56. return x&
      57. EndProc
      58. Proc popcount32b :parameters x&
      59. //This uses fewer arithmetic operations than any other known
      60. //implementation on machines with slow multiplication.
      61. //Algorithm uses 17 arithmetic operations.
      62. x&=x&-((x&>>1) & &m1) //put count of each 2 bits into those 2 bits
      63. x&=(x& & &m2)+((x&>>2) & &m2) //put count of each 4 bits into those 4 bits
      64. x&=(x&+(x&>>4)) & &m4 //put count of each 8 bits into those 8 bits
      65. x&=x&+(x&>>8) //put count of each 16 bits into their lowest 8 bits
      66. x&=x&+(x&>>16) //put count of each 32 bits into their lowest 8 bits; End of 32-bit
      67. // x&=x&+(x&>>32) //put count of each 64 bits into their lowest 8 bits; case 64-bit
      68. return x& & $7f
      69. EndProc
      70. Proc popcount32c :parameters x&
      71. //This uses fewer arithmetic operations than any other known
      72. //implementation on machines with fast multiplication.
      73. //&his algorithm uses 12 arithmetic operations, one of which is a multiply.
      74. x&=x&-((x&>>1) & &m1) //put count of each 2 bits into those 2 bits
      75. x&=(x& & &m2)+((x&>>2) & &m2)//put count of each 4 bits into those 4 bits
      76. x&=(x&+(x&>>4)) & &m4 //put count of each 8 bits into those 8 bits
      77. return (x&*&h01)>>56 //returns left 8 bits of x + (x<<8) + (x<<16) + (x<<24) + ...
      78. EndProc
      79. 'Die obigen Implementierungen haben das beste Worst-Case-Verhalten aller bekannten Algorithmen.
      80. 'Wenn jedoch erwartet wird, dass ein Wert wenige Bits ungleich Null hat, kann es stattdessen
      81. 'effizienter sein Algorithmen zu verwenden, die diese Bits einzeln zählen. Wie Wegner [1960]
      82. 'beschreibt, unterscheidet sich das bitweise UND von x mit x-1 von x nur durch das Nullsetzen
      83. 'des niederwertigsten Bits - Subtrahieren von 1 ändert den rechten String von 0s zu 1s und
      84. 'den rechten String von 1 zu 0. Wenn x ursprünglich n Bits hatte, die 1 waren, wird x nach
      85. 'nur n Iterationen dieser Operation auf Null reduziert. <Übersetzt mit www.DeepL.com/Translator>
      86. Proc popcount_d :parameters x& //This is better when most bits in x are 0.
      87. //This is algorithm works the SAME FOR ALL DATA SIZES.
      88. //It uses 3 arithmetic operations and 1 comparison/branch per %1 in x.
      89. var count&=0
      90. While x&
      91. inc count&
      92. x&=x& & (x&-1)
      93. endwhile
      94. return count&
      95. Endproc
      96. 'Wenn uns mehr Speicherplatz zur Verfügung steht, können wir das Hamming-Gewicht schneller
      97. 'berechnen als die oben genannten Methoden. Mit unbegrenztem Speicher könnten wir einfach
      98. 'eine große Lookup-Tabelle mit dem Hamming-Gewicht jeder 64-Bit-Ganzzahl erstellen.
      99. 'Wenn wir eine Lookup-Tabelle der Hamming-Funktion jeder 16-Bit Ganzzahl speichern können,
      100. 'können wir folgendes tun, um das Hamming-Gewicht jeder 32-Bit-Ganzzahl zu berechnen:
      101. //Declare Wordbits&[65535] // bitcounts of integers 0 through 65535
      102. Proc popcount32e_init
      103. // For filling the wordbits[] table, use the fastest function for your system.
      104. whileloop 0,$ffff
      105. wordbits&[&Loop]=popcount_d(&Loop) // if fastest
      106. Endwhile
      107. Endproc
      108. // Now we simply can do a lookup 2 times
      109. Proc popcount32e :parameters x&
      110. //This algorithm uses 3 arithmetic operations and 2 memory reads only
      111. return int(wordbits&[x& & $ffff]+wordbits&[x&>>16])
      112. EndProc
      113. // HINT
      114. // Mula et al. [11] have shown that a vectorized version of popcount64b can run
      115. // faster than dedicated instructions (e.g., popcnt on ×64 processors).
      Alles anzeigen
    • Neu

      Abt. Wie der PopCount_d-Algorithmus funktioniert
      ===============================
      Eine Ergänzung zum obigen Programm.
      Gruss

      Quellcode

      1. WindowTitle "Zum Verständnis des PopCount_d-Algorithmus"
      2. declare x&:Cls:font 2
      3. repeat
      4. print "\n ZAHL = ";
      5. input x&
      6. case x&=-9:x&=%1111100001111101111010101010101010110010010101
      7. print popcount_d(x&)
      8. until 0
      9. Proc popcount_d :parameters x&
      10. var count&=0
      11. print "\n";right$("0000000000000000000000000000000"+bin$(x&),32),count&
      12. While x&
      13. inc count&
      14. x&=x& & (x&-1)
      15. print right$("0000000000000000000000000000000"+bin$(x&),32),count&
      16. waitinput 300
      17. endwhile
      18. print "\n ";
      19. return count&
      20. Endproc
      21. waitinput
      Alles anzeigen
    • Neu

      Abt. Noch mehr Rätsel - NmR 70 ´Fun mit Fun´
      ==================================
      Die hier beschriebene Funktion gilt für positive Integers größer Null, also die natürlichen Zahlen:
      Fun(2) liefert als Ergebnis den Wert 3, denn es ist bekannt: Fun(a+b) liefert Fun(a)+Fun(b)+a*b.
      Fritz will wissen, was Fun(11) ergibt, aber er kommt nicht darauf. Deshalb bleibt das ein ewiges Rätsel. Oder?

      Dieser Beitrag wurde bereits 4 mal editiert, zuletzt von p. specht ()

    • Neu

      Lösung zu NmR 70:
      ---------------------
      Zugegeben, das war aus einer Mathe-Olympiade - da braucht man schon etwas länger.
      Also erst mal selbst versuchen, dann aufdecken!
      Gruss

      Spoiler anzeigen
      Bleibt das ein ewiges Rätsel? Nein! Die Angaben genügen, wenn man Einstein heißt oder den Kopf etwas schief hält und dabei leichte Schläge auf den Hinterkopf ausführt:

      Fun(2) = Fun(a + b) ==> a + b = 2.
      Da definiert auf den natürlichen Zahlen, kann das nur bedeuten:
      2 = 1 + 1 = a + b ==> a=1, b=1 - eine spezielle Lösung für Fun(2).

      Daraus lässt sich weiter schließen:

      Fun(a+b) = Fun(a)+Fun(b)+a*b,

      konkreter:

      Fun(2) = Fun(1)+Fun(1)+1*1,

      und eingesetzt:

      3 = Fun(1) + Fun(1) + 1
      3 = 2*Fun(1) + 1
      2 = 2*Fun(1)
      2/2 = Fun(1)

      Aha, wir haben also einen zweiten speziellen Wert:
      Fun(1) = 1
      -----------

      Und hier kommt der Trick: Dieses Zwischenergebnis erlaubt uns, die Formel auf eine Rekursion zurückzuführen, indem wir bei variierbarem a weiter an b = 1 festhalten: Aus

      Fun(a+b) = Fun(a)+Fun(b)+a*b

      wird dann:

      Fun(a+1) = Fun(a) +Fun(1)+a*1,

      und wegen Fun(1)=1 folgt weiter:
      ************************
      Fun(a+1) = Fun(a) + a + 1
      ************************
      Damit können wir die Frage von Fritz schon besser beantworten:

      F(11) = F(10)+10+1 = F(10)+11. Wir brauchen nur noch F(10) !
      F(10) = F(9)+9+1 = F(9)+10. Wir brauchen also nur noch F(9) !
      F(9) = ...
      Und wann ist Schluss? Bei
      F(1) = F(0)+0+1 = 1,
      kleiner gehts nicht bei den natürlichen Zahlen!

      Daher ist das Ergebnis:
      F(11) = 11 + 10 + 9 + ... + 1 = 66
      ===========================

      P.S.: Was wäre dann F(426)? Da wird Addieren zu mühsam.
      Dankenswerter Weise kommt uns da aber der "kleine Gauß" zur Hilfe, mit seiner Formel

      SUM(N) = (N+1)*N/2

      Checken wir´s:
      F(11) = (11+1)*11/2 = 66
      F(426) = 90951
      Wer will, kann´s ja durch addiren überprüfen ;-)

    • Neu

      Abt. Dreiseitige Münze
      ===============
      (Update zu diesem Beitrag hier)
      Wenn man unbedingt eine Entscheidung zu treffen hat, aber keine Datengrundlagen verfügbar sind und auch Logik, Erfahrung und Bauchgefühl versagen, dann wirft man z.B. eine Münze. Fairerweise sollte man sich vorher im Klaren sein, was Kopf oder Zahl jeweils bedeuten sollen.

      In ganz seltenen Fällen kann es vorkommen, daß die Münze auf der Kante stehenbleibt! Die Wahrscheinlichkeit dafür wird sogar etwas größer, wenn man die Münze auf einer ausgerichteten Tischplatte schnell dreht. Die Chancen werden weiters umso größer sein, je breiter der Durchmesser der Münze im Verhältnis zum Rand ist (Wir gehen von eiinem scharfkantigen Rand und Wurf aus einem Becher aus).

      Eine Stange (Zylinder bzw. "Münze mit superdickem Rand") wird dagegen selten auf den Abschlußflächen zu liegen kommen, wenn man ihn wirft. Irgendwo muss also ein Verhältnis Durchmesser_zu_Rand existieren, wo die Wahrscheinlichkeit, auf dem Rand zu liegen zu kommen genau so groß ist wie die, auf einer Endfläche liegen zu bleiben. Experten streiten darüber, welches Verhältnis hier herauskommt. Sie liegt aus mechanischen Gründen irgendwo zwischen Sqrt(3) = 1.732050808 und 2*Sqrt(2) = 2.828427125.

      NEU: Statistische Ergebnisse (jeweils 2000 Münzwürfe mit Experimentalmünzen unterschiedlicher Dicke) deuten auf eine Zahl irgendwo um den Mittelwert 1.855265073 hin. Da spielt aber sogar die Glätte der Tischoberfläche (Reibung), das Gewicht und das Elastizitätsverhalten der verwendeten Materiialien eine Rolle.
      Gruss


      P.S.: Youtube (engl.)

      Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von p. specht ()

    • Neu

      Abt. Motivator 1.0
      =============
      Down? Wütend? Alles Idiioten? Das folgende Spass-Programm :-D sollte die Stimmung wieder heben! Man muß nur daran glauben und lange genug auf den Bildschirm starren. Kaum ist die Laune wieder besser, beendet ein längerer Tastendruck den Spuk! Have fun!
      Gruss

      P.S.: Dzt. nur für Bildschirmauflösung 1366 x 768 optimierit - aber ihr könnt den Sch.. ja jederzeit anpassen!

      Quellcode

      1. WindowTitle " MOTIVATOR 1.0"
      2. '(CL) CopyLeft for_non-commercial use 2018-08 by P.Specht, Vienna/EU
      3. WindowStyle 24:Window 0,0-%maxx,%maxy:Showmax
      4. Declare xh&,yh&,x&,y&,r!,a!,b!,f!,c&
      5. xh&=width(%hwnd)/2:yh&=height(%hwnd)/2
      6. f!=pi()/180
      7. REPEAT
      8. Whileloop 0,360,12:b!=&Loop*f!
      9. MCLS %maxx,%maxy,$FFFFFF:StartPaint -1
      10. r!=7:x&=r!*cos(a!):y&=r!*sin(a!)
      11. moveto xh&+x&,yh&-y&
      12. whileloop 0,7*360,2
      13. a!=&Loop*f! + b!
      14. x&=r!*cos(a!):y&=r!*sin(a!)
      15. usepen 0,r!/10,rgb(170,70,255)
      16. lineto xh&+x&+1,yh&-y&
      17. r!=r!+0.3333333333
      18. endwhile
      19. usefont "Arial",170,70,1,0,0
      20. TextColor rgb(Sqrt(b!)*200,140,140),-1
      21. Drawtext 35,yh&-90,"ALLES WIRD GUT!"
      22. EndPaint:MCopyBMP 0,0-%maxx,%maxy>1,0;0
      23. EndWhile
      24. Waitinput 32
      25. UNTIL %Key>0
      26. END
      Alles anzeigen

      Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von p. specht ()

    • Neu

      Abt. Motivator 1.01
      ============
      NEU: Jetzt NOCH hypnotischer (und mit verbessertem Rundlauf) !

      Quellcode

      1. WindowTitle " MOTIVATOR 1.01"
      2. '(CL) CopyLeft for_non-commercial use 2018-08 by P.Specht, Vienna/EU
      3. WindowStyle 24:Window 0,0-%maxx,%maxy:Showmax
      4. Declare xh&,yh&,x&,y&,r!,a!,b!,f!,c&
      5. xh&=width(%hwnd)/2:yh&=height(%hwnd)/2
      6. f!=pi()/180
      7. REPEAT
      8. Whileloop 0,359,12:b!=&Loop*f!
      9. r!=3:x&=r!*cos(a!):y&=r!*sin(a!)
      10. MCLS %maxx,%maxy,$FFFFFF:StartPaint -1
      11. moveto xh&+x&,yh&-y&
      12. whileloop 0,2553,2
      13. a!=&Loop*f! + b!
      14. x&=r!*cos(a!):y&=r!*sin(a!)
      15. usepen 0,r!/11,rgb(70,70,90+130*cos(15*a!))
      16. lineto xh&+x&+1,yh&-y&
      17. r!=r!*0.9998+0.3333333333
      18. endwhile
      19. usefont "Arial",170,70,1,0,0
      20. c&=120+120*cos(b!)
      21. TextColor rgb(255,c&,c&),-1
      22. Drawtext 35,yh&-90,"ALLES WIRD GUT!"
      23. EndPaint:MCopyBMP 0,0-%maxx,%maxy>1,0;0
      24. EndWhile
      25. UNTIL 0
      Alles anzeigen
    • Neu

      Abt. Eratosthenes-Sieb mit Prim-Zerlegung
      ===============================
      Zum hm-zigsten Mal, die bekannte Variante mit MOD, aber diesmal als Proc.
      Gruss

      Brainfuck-Quellcode

      1. WindowTitle "Sieb des Eratosthenes mit Primfaktorenzerlegung"
      2. CLS:font 2:declare Factors&[],ZAHL&
      3. Lup:
      4. Clear Factors&[],Zahl&
      5. Print "\n Zu prüfende Zahl [<= 2^24]: ";
      6. Input Zahl&
      7. if (Zahl&<2) or (Zahl&>2^24)
      8. print " Out of range! "
      9. sound 100,100
      10. goto "Lup"
      11. endif
      12. getPrimeFactors Zahl&,factors&[]
      13. if (zahl&=2) or (sizeof(factors&[])=1)
      14. print "\n ";Zahl&;" IST EINE PRIMZAHL!"
      15. sound 1000,50
      16. else
      17. print "\n ";Zahl&;" ist keine Primzahl!\n\n ";
      18. Whileloop 0,sizeof(factors&[])-1
      19. print factors&[&Loop],
      20. endwhile
      21. print " (";sizeof(factors&[]);" Faktoren)"
      22. sound 3000,21
      23. EndIf
      24. goto "Lup"
      25. '---------
      26. Proc getPrimeFactors :parameters N&,factors&[]
      27. casenot between(n&,2,2^24-3):return
      28. var factor&=2
      29. While 1
      30. If (N& mod factor&)=0
      31. factors&[sizeof(factors&[])]=factor&
      32. N& = N& \ factor&
      33. case N&=1:Return
      34. Else
      35. inc factor&
      36. EndIf
      37. Wend
      38. EndProc
      Alles anzeigen
    • Neu

      Abt. Münchhausenzahlen finden
      ====================
      Es handelt sich um Zahlen, die sich an ihrer eigenen Potenzierung aus der Addition ziehen, wie weiland Lügenbaron Münchhausen sich an den Stiefelschlaufen ("Bootstrap") aus dem Sumpf zog. Es wird halt viel gelogen in der Welt, hier aber nur ein wenig geschummelt.
      Gruss

      Quellcode

      1. WindowTitle "Die vier Münchhausen-Zahlen finden"
      2. declare i&,j&,k&,l&,m&,n&,o&,p&,q&,r&,s&,tm&,Luege&
      3. Proc FNexp :parameters x&
      4. casenot x&:return 0
      5. return x&^x&
      6. Endproc
      7. CLS:font 2
      8. '0, 1, 3435, 438579088
      9. tm&=&gettickcount
      10. Whileloop 0,9:s&=&Loop
      11. Whileloop 0,9:i&=&Loop
      12. Whileloop 0,9:j&=&Loop
      13. Whileloop 0,9:k&=&Loop:print "-";
      14. whileloop 0,9:l&=&Loop
      15. Whileloop 0,9:o&=&Loop
      16. Whileloop 0,9:p&=&Loop
      17. Whileloop 0,9:q&=&Loop
      18. whileloop 0,9:r&=&Loop
      19. IF Luege&:s&=4:i&=3:j&=8:k&=5:endif
      20. m&=FNexp(s&)+FNexp(i&)+FNexp(j&)+FNexp(k&)+FNexp(l&)+FNexp(o&)+FNexp(p&)+FNexp(q&)+FNexp(r&)
      21. n&=100000000*s&+10000000*i&+1000000*j&+100000*k&+10000*l&+1000*o&+100*p&+10*q&+r&
      22. if (m&=n&) AND (m&>=0)
      23. Print "\n ";m&;" = ";tab(22);i&;"^";i&;" + ";j&;"^";j&;" + ";k&;"^";k&;" + ";l&;"^";l&;\
      24. " + ";o&;"^";o&;" + ";p&;"^";p&;" + ";q&;"^";q&;" + ";r&;"^";r&
      25. Print " Ticks: ";int(&gettickcount-tm&);" ms"
      26. case m&=3435:Luege&=1
      27. if m&=438579088:waitinput 5000
      28. print "\n OK, bei der 4. wurde geschummelt... dauert sonst 1 Woche!"
      29. sound 2000,50:waitinput:end
      30. endif
      31. endif
      32. Endwhile
      33. Endwhile
      34. Endwhile
      35. Endwhile
      36. Endwhile
      37. Endwhile
      38. Endwhile
      39. Endwhile
      40. Endwhile
      41. print "\n OK. Ticks gesamt: ";int(&gettickcount-tm&);" ms"
      42. sound 2000,200
      43. waitinput
      44. END
      Alles anzeigen
    • Neu

      Abt. Witzige Zahlen
      =============
      Smith-Zahlen sind Zahlen, deren Ziffernsumme der Ziffernsumme ihrer Primfaktoren gleich ist.
      Sie werden manchmal auch als ´Witzige Zahlen´ bezeichnet. Achtung: Per Definition gelten die Primzahlen selbst NICHT als Smith-Zahlen! Anbei ein Progi zu ihrer Ermittlung!
      Gruss

      Quellcode

      1. WindowTitle " SMITH-ZAHLEN zwischen 0 und 10000 ermitteln"
      2. 'Q: http://rosettacode.org/wiki/Smith_numbers#FreeBASIC
      3. '(DT) Demo-Translation 2018-08 by P.Specht, Vienna/EU
      4. 'Achtung, Falle!: In XProfan-11 ist es nicht erlaubt,
      5. 'aus Repeat/While/Whileloop mit Return herauszuspringen !!
      6. WindowStyle 24:CLS:font 1:print:set("numwidth",5)
      7. 'Smith-Zahlen sind Zahlen, deren Ziffernsumme der Ziffernsumme ihrer Primfaktoren gleich ist.
      8. 'Sie werden manchmal auch als ´Witzige Zahlen´ bezeichnet.
      9. 'Achtung: Per Definition gelten die Primzahlen selbst NICHT als Smith-Zahlen!
      10. Declare count&,i&,j&,n&,factors&[],primeSum&
      11. Begin:
      12. Whileloop 2,9999:j&=&Loop
      13. If isSmith(j&)
      14. Print j&;
      15. inc count&
      16. case %pos>70:print
      17. EndIf
      18. Endwhile
      19. Print "\n ";count&;" Smith-Zahlen gefunden!"
      20. sound 2000,100:Print "--------"
      21. Waitinput
      22. End
      23. Proc isSmith :parameters n&
      24. case n&< 2:Return 0
      25. clear factors&[]
      26. getPrimeFactors(n&)
      27. case (sizeof(factors&[])-1) = 0:Return 0
      28. clear primeSum&
      29. Whileloop 0,sizeof(factors&[])-1:i&=&Loop
      30. primeSum& = primeSum& + sumDigits(factors&[i&])
      31. Endwhile
      32. Return sumDigits(n&) = primeSum&
      33. EndProc
      34. Proc getPrimeFactors :parameters K&
      35. casenot between(K&,2,2^24-3):return 0
      36. var factor&=2
      37. REPEAT
      38. IF (K& mod factor&)=0
      39. factors&[sizeof(factors&[])]=factor&
      40. K& = K& / factor&
      41. case K&=1:BREAK '<<statt return
      42. ELSE
      43. inc factor&
      44. ENDIF
      45. UNTIL 0
      46. return sizeof(factors&[])
      47. EndProc
      48. Proc SumDigits :parameters x& 'Schnelle Ziffernsumme
      49. case x&<10:Return x&
      50. declare sum&
      51. While x&>0
      52. sum&=sum&+(x& mod 10)
      53. x& = x& \ 10
      54. EndWhile
      55. Return sum&
      56. EndProc
      57. 'The Smith numbers below 10000 are:
      58. ' 4 22 27 58 85 94 121 166 202 265 274 319 346 355 378 382
      59. ' 391 438 454 483 517 526 535 562 576 588 627 634 636 645 648 ...
      60. ' .... 9633 9634 9639 9648 9657 9684 9708 9717 9735 9742 9760 9778 9840 9843 9849
      61. ' 9861 9880 9895 9924 9942 9968 9975 9985
      62. '376 numbers found
      Alles anzeigen