ALGORITHMEN TEIL X: Das hat uns noch gefehlt!

WindowTitle "Gunkelzahlen finden (Brute force-Methode)"
' Problemstellung von http://www.gunkl.at/tips-system/archiv.php, dort aus:
' Gunkl-Tipp vom 22.10.2015: Finden sie ein paar vierstellige Zahlen, die, 
' durch alle möglichen zweistelligen Zahlen, die sich aus den vier Z i f f e r n 
' basteln lassen, dividiert, eins ergeben.
' Specht's Vermutung: Gemeint dürften Zahlen nach folgendem Muster sein: 1234 / 23 / 14 = 1 ?
Windowstyle 24:CLS:font 0
declare v&,v$,t&,h&,z&,e&, tt&,hh&,zz&,ee&, z1&,z2&,p$[],i&[23,3],z$,k&,z1o&,z2o&
p$[]=explode("0123,0132,0213,0231,0312,0321,1023,1032,1203,1230,1302,1320,1023,1032,1203,"+\
"1230,1302,1320,2013,2031,2103,2130,2301,2310,3012,3021,3102,3120,3201,3210,",",")
:whileloop 0,23:k&=&Loop:z$=p$[k&]:whileloop 0,3:i&[k&,&Loop]=val(mid$(p$[k&],&loop+1,1))
'print i&[k&,&Loop],
endwhile :'print
endwhile :clear p$[]
Clearclip:Cls ' Vierstellige Zahl aus 4 Ziffern bilden:
Whileloop 0,9:t&=&loop:Whileloop 0,9:h&=&loop:Whileloop 0,9:z&=&loop:Whileloop 0,9:e&=&loop
v&=t&*1000+h&*100+z&*10+e&:v$=right$("0000"+str$(v&),4):print v$:locate %csrlin-1,1
  ' DIESE Ziffern permutieren:
   z1o&=99:z2o&=99
   whileloop 0,23
     tt&=val(mid$(v$,i&[&Loop,0]+1,1))
     hh&=val(mid$(v$,i&[&Loop,1]+1,1))
     zz&=val(mid$(v$,i&[&Loop,2]+1,1))
     ee&=val(mid$(v$,i&[&Loop,3]+1,1))
  ' Zweiergruppen bilden
     z1&=10*tt&+hh&
     z2&=10*zz&+ee&
  ' Test und ggf. Ausgabe
       if (v&=z1&*z2&) and (((z1&<>z1o&)  and (z2&<>z2o&)) and ((z1&<>z2o&)  and (z2&<>z1o&)) )
         print v$,z1&,z2&,if(v&=0,"Triviale Lösung"," Probe: "+format$("%g",v&/z1&/z2&))
         putclip v$+" "+str$(z1&)+" "+str$(z2&)+if(v&=0,"Triviale Lösung","")+";\n"
         z1o&=z1&:z2o&=z2&
       endif
   endwhile  
  z1o&=99:z2o&=99
endwhile:endwhile:endwhile:endwhile:locate %csrlin,1:print "   OK.   ":waitinput:End

WindowTitle "Stein´scher Algorithmus auf Double-Precision Floats gebracht"
' (CL) Copyleft 2015-11 by P. Specht, Wien; OHNE JEDWEDE GEWÄHR!
WindowStyle 24:font 2:Declare w$,a!,b!:set("decimals",17)


Loop:
Cls:print "\n  Divisor: ";:input w$
if right$("0000000000000000"+w$,16)>"9007199254740992"
  print "  Err! Max 9007199254740992":beep:waitinput :goto "Loop":endif
a!=val(w$):print " Dividend: ";:input w$
if right$("0000000000000000"+w$,16)>"9007199254740992"
  print " Maximal 9007199254740992":beep:waitinput :goto "Loop":endif 
b!=val(w$)
print "\n Größter Gemeinsamer Float-Teiler GGFT nach Stein: ";
print format$("%g",SteinFloat(a!,b!))
beep:waitinput :Goto "Loop"


Proc SteinFloat :parameters a!,b!
declare k&,erg!,t!:if (a!=0) or (b!=0):erg!=0:goto "SteinFloatExit":endif
WhileNot (Mod2f(a!) or Mod2f(b!))
  a!=IntS(a!/2):b!=IntS(b!/2):inc k&
endwhile :if Mod2f(a!):t!= -1*b! :else :t!=a!:endif
while t!<>0
  whilenot Mod2f(t!):t!=IntS(t!/2):endwhile    
  if t!>0:a!=t!:else :b!= -1*t!:endif :t!=a!-b!
endwhile :erg!=a!*(2^k&)
SteinFloatExit:
return erg!
EndProc
proc IntS :parameters x!
declare ds&,int$:ds&=get("decimals"):set("decimals",17)
int$=substr$(str$(x!),1,"."):set("decimals",ds&):return val(int$)
endproc
proc Mod2f :parameters x!:var ds&=get("decimals"):set("decimals",17)
var g!=x!/2:g!=not(g!=IntS(g!)):set("decimals",ds&):return int(g!)
endproc

WindowTitle "Double Precision Floats binär dargestellt":font 2
'
Windowstyle 24:Window %maxx*0.125,%maxy*0.125 - %maxx*0.75,%maxy*0.75
set("decimals",17):set("numwidth",30):print
declare x![],b# : dim b#,8


var n&=0
x![n&]=0
inc n&:x![n&]=1
inc n&:x![n&]=2
inc n&:x![n&]= -1
inc n&:x![n&]=val("-1e-1")
inc n&:x![n&]= -2
inc n&:x![n&]=10
inc n&:x![n&]=Pi()
inc n&:x![n&]=val("-1e-306")
inc n&:x![n&]=2^-306
inc n&:x![n&]=val("-1.0e-308")
inc n&:x![n&]=val("-1.0e-309")
inc n&:x![n&]=val("-1.0e-310")
inc n&:x![n&]=val("-2.0e-310")
inc n&:x![n&]=val("-3.0e-310")
inc n&:x![n&]=val("%10000000000000000000000000000000")
inc n&:x![n&]=9007199254740992


whileloop 0,sizeof(x![])-1
   float b#,0=x![&Loop]:show_bin(b#,x![&Loop])
endwhile
dispose b#
waitinput
End


proc show_bin :parameters b#,x!
declare i&,w&:print " "+format$("%g",x!),tab(26);
whileloop 7,0,-1:i&=&Loop
w&=byte(b#,i&)
if i&=7
  print bin$(w&>127)+" "+right$("0000000"+bin$(w& & 127),7)+" ";
elseif i&=6
  print right$("0000"+bin$(w&>>4),4)+if(x!=0,"   o.","   l.")+right$("0000"+bin$(w& & 15),4)+" ";
else
  print right$("00000000"+bin$(w&),8),
endif
endwhile 


var w$=right$("0000000"+bin$(byte(b#,7) & 127),7)+right$("0000"+bin$(byte(b#,6)>>4),4)


print "..*2^"+format$("%g",val("%"+w$)-1023)
print
endproc

WindowTitle upper$("   R I N G S Y M M E T R I E :    "+\
"A r m r e i f s c h m u c k s t e i n m u s t e r p r o b l e m")
AppendMenubar 100, "von homepages.fh-friedberg.de/boergens/problem/problem_01_09loe.htm"
Declare i&
Cls
print "\n Eine Firma verkauft goldene Armreifen mit verschiedenfarbigen"
print " Schmucksteinen gleichverteilt am Umfang. Wievielen Käufern kann"
print " bei n unterschiedlichen Schmucksteinen garantiert ein Unikat   "
print " betreffend das Muster, das die Steine bilden, verkauft werden ?"
print " [Taste]":waitinput :cls:print:font 2
print " Anzahl der Schmucksteine   Anzahl möglicher Unikate ":print
whileloop 29:i&=&Loop
  print mkstr$(" ",20-len(str$(i&)))+str$(i&);tab(32);
  print translate$(format$("%g",round(faku(i&-1)/2,0)),"E0"," * 10 ^ ")
endwhile
waitinput:Print " Ciao!"
waitinput 4000:End
proc faku :parameters i&:var prod!=1
whileloop i&:prod!=prod!*&Loop:endwhile:return prod!
endproc

WindowTitle "Brute Force Attack auf das Kinder+lein=kommet Problem"
'Quelle: http://homepages.fh-friedberg.de/boergens/problem/problem_01_12.htm
font 2:declare k&,i&,n&,d&,e&,r&,l&,o&,m&,t&,count&
cls':Window 0,0-%maxx,%maxy
clearclip
i&=0:o&=1 ' ... aus Angabe evident, spart 3/4 Rechenzeit
whileloop 2,9:k&=&Loop
whileloop 2,9:n&=&Loop:case n&=k&:continue
whileloop 2,9:d&=&Loop:case (d&=n&) or (d&=k&):continue
whileloop 2,9:e&=&Loop:case (e&=d&) or (e&=n&) or (e&=k&):continue
whileloop 2,9:r&=&Loop:case (r&=e&) or (r&=d&) or (r&=n&) or (r&=k&):continue
whileloop 2,9:l&=&Loop:case (l&=r&) or (l&=e&) or (l&=d&) or (l&=n&) or (l&=k&):continue
whileloop 2,9:m&=&Loop
case (m&=l&) or (m&=r&) or (m&=e&) or (m&=d&) or (m&=n&) or (m&=k&):continue
whileloop 2,9:t&=&Loop
case (t&=m&) or (t&=l&) or (t&=r&) or (t&=e&) or (t&=d&) or (t&=n&) or (t&=k&):continue


  if (k&*100000+i&*10000+n&*1000+d&*100+e&*10+r& + l&*1000+e&*100+i&*10+n& )\
   = (k&*100000+o&*10000+m&*1000+m&*100+e&*10+t&)
  print ".";
    if (k&<>i&) and (k&<>n&) and (k&<>d&) and (k&<>e&) and (k&<>r&) and (K&<>l&) and (k&<>o&) and \
    (k&<>m&) and (k&<>t&) AND (i&<>n&) and (i&<>d&) and (i&<>e&) and (i&<>r&) and (i&<>l&) and \
    (i&<>o&) and (i&<>m&) and (i&<>t&) AND (n&<>d&) and (n&<>e&) and (n&<>r&) and (n&<>l&) and \
    (n&<>o&) and (n&<>m&) and (n&<>t&) AND (d&<>e&) and (d&<>r&) and (d&<>l&) and (d&<>o&) and \
    (d&<>m&) and (d&<>t&) AND (e&<>r&) and (e&<>l&) and (e&<>o&) and (e&<>m&) and (e&<>t&) AND \
    (r&<>l&) and (r&<>o&) and (r&<>m&) and (r&<>t&) AND (l&<>o&) and (l&<>m&) and (l&<>t&) AND \
    (o&<>m&) and (o&<>t&) AND (m&<t&)
    'print "k=";k&,"i=";i&,"n=";n&,"d=";e&,"r=";r&,"l=";l&,"o=";o&,"m=";m&,"t=";t&
     print
     print k&;i&;n&;d&;e&;r&
     print "  ";l&;e&;i&;n&
     print "------"
     print k&;o&;m&;m&;e&;t&
     inc count&
     putclip str$(count&)+": k="+str$(k&)+",i="+str$(i&)+",n="+str$(n&)+",d="+str$(e&)+\
",r="+str$(r&)+",l="+str$(l&)+",o="+str$(o&)+",m="+str$(m&)+",t="+str$(t&)+"\n"
  endif
endif
endwhile
endwhile
endwhile
endwhile
endwhile
endwhile
endwhile
endwhile
print " FERTIG."
print "\n Anzahl gefundener Lösungen: ";count&
print " Details in der Zwischenablage!"
beep
waitinput
waitinput
end

WindowTitle upper$("Faltlagen-Code für Blattbahnen erstellen")
WindowStyle 24 '(CL) CopyLeft by P. Specht, Wien. OHNE JEDWEDE GEWÄHR! 
declare n&,d!,f&,i&,k&,w&,m&,L&[]'(Nullinitialisierung vorausgesetzt)
start:
cls:beep
print "\n  Wie oft wird gefaltet? F = ";:input f&
print " Wie dick ist eine Lage? d = ";:input d!
set("decimals",0):n&=2^f&
print "\n  Es entstehen 2^";f&;" = ";n&;" Lagen."
set("decimals",2)
case d!>0:print "  Die Ballenhöhe beträgt theoretisch ";d!*n&;" Einheiten."
print "\n  Es kommen folgende Lagenverbindungskennzahlen übereinander zu liegen."
print "  Dabei wird stets nach oben (vorne) gefaltet. Die Ausgabe erfolgt von   "
print "  der untersten Lagezahl zur obersten. Welche Lagen miteinander zusammen-"
print "  hängen ist durch die numerisch aufsteigende Lagereihenfolge erkennbar. \n"
print "  [ Berechnung läuft ... ]";:locate %csrlin,1
casenot sizeof(L&[]):clear L&[]
setsize L&[],n&
m&=n&-1
whileloop 0,m&:i&=&Loop
   w&=Setbit(w&,0,Testbit(i&,0))
   whileloop 1,f&-1:k&=&Loop
     w&=setbit(w&,k&,XOR(Testbit(w&,0),Testbit(i&,f&-k&)))
  endwhile
  L&[i&]=w&
  w&=0
endwhile


font 2:print " ";
whileloop 0,m&
  print L&[&Loop]; 'tab(10);right$(mkstr$("0",f&-1)+bin$(L&[&Loop]),f&)
  case &Loop<m&:print ",";
  case %pos>60:print "\n ";
  case &Loop=m&:print "                      "
endwhile
waitinput
goto "start"

WindowTitle upper$("Moduloide")
'(TW) Trashware by P. Specht, Wien; OHNE JEDWEDE GEWÄHR!
' Quelle: https://www.youtube.com/watch?v=qhbuKbxJsk8
WindowStyle 24:randomize:Window 0,0-%maxx,%maxy
declare i&,j&,k&,n&,co&,r!,s!,faktor!:font 2:CLS
declare x&[],y&[],pi2!,u!,xh&,yh&:set("decimals",2)
pi2!=pi()*2:xh&=width(%hwnd)\2:yh&=height(%hwnd)\2


r!=yh&*0.96
whileloop 80,220:i&=&Loop ' 200
  MCLS %maxx,%maxy,$FFFFFF  
  usebrush 0,0:usepen 0,3,rgb(255,0,0)  
  whileloop 3*i&:faktor!=&Loop/15
    StartPaint -1
    cls
    locate 1,1:print i&;"-Eck mit Faktor ";faktor!;
    s!=pi2!/i&:u!=0    
    while u!<pi2!
      x&[n&]=xh&+r!*cos(u!)
      y&[n&]=yh&-r!*sin(u!)
      'usepen 0,3,rgb(255,0,0)
      'ellipse x&[n&]+3,(y&[n&]+3) - x&[n&]-3,y&[n&]-3
      drawtext x&[n&],y&[n&],n&
      u!=u!+s!
      inc n&
    endwhile  
    if n&>1
      co&=rgb(rnd(180),rnd(256),10*faktor!)
      whileloop n&-1:j&=&Loop
        k&=(j&*faktor!) mod (n&-1)
        usepen 0,2,co&
        line x&[j&],(y&[j&]) - x&[k&],y&[k&]
      endwhile
    endif  
    EndPaint:MCopyBMP 0,0 - %maxx,%maxy > 0,0;0
    'waitinput 150
    n&=0:clear x&[],y&[]
  endwhile
endwhile
beep:print "ok":waitinput :End

WindowTitle upper$("unicode-generator")
' OHNE JEDWEDE GEWÄHR! PFADE GGF. SELBST ANPASSEN!
  WindowStyle 24:cls:font 2:randomize
  var user$=getenv$("USERNAME"):declare i&,j&


var MaxCodePlane&=255


  print "\n Kontrolle: Ist Ihr Benutzername = ";chr$(34);user$;chr$(34);"?"
  print "\n Falls nicht: Bitte   A B B R E C H E N !":waitinput


assign #1,"C:\\Users\\"+User$+"\\Desktop\\all_ucod.txt"
rewrite #1


  print #1,chr$($FE);chr$($FF); 'Unicode-Kennung
  whileloop 0,MaxCodePlane&:i&=&Loop

    whileloop 0,255:j&=&Loop
      print #1,chr$(i&);chr$(j&);
      print #1,chr$(0);chr$(32);
      casenot j& mod 64:print #1,chr$(0);chr$(13);chr$(0);chr$(10);
    endwhile
      print #1,chr$(0);chr$(13);chr$(0);chr$(10);
      print #1,chr$(0);chr$(13);chr$(0);chr$(10);
  endwhile
  print #1,chr$(0);chr$(0);chr$(0);chr$(0);


close #1
print "\n\n Datei liegt am Desktop.\n BYE!"


beep:waitinput 2000
end
progend


     Unicode  ASCII
-----------------------
 CR	 000D 	    0D 	
 LF  000A 	    0A 	
CRLF 000D,000A 	0D,0A  
 NEL*0085 	 85 
 VT  000B 	 0B 
 FF	 000C 	 0C 
 LS	 2028 	 n/a
 PS	 2029 	 n/a