@ Michael W.: Spitze! Besonderen Dank für die GOTO-freie Variante!
Abt. Mathe-Links
==========
Ab ins ZAHLENREICH (engl.) :idea:
Oder: Knifflige Mathe-Rätsel gefällig? 8O
Es gibt sogar Mathe-Witze & -Anekdoten
Gruss
@ Michael W.: Spitze! Besonderen Dank für die GOTO-freie Variante!
Abt. Mathe-Links
==========
Ab ins ZAHLENREICH (engl.) :idea:
Oder: Knifflige Mathe-Rätsel gefällig? 8O
Es gibt sogar Mathe-Witze & -Anekdoten
Gruss
Abt. Gregory-Integration
================
Inzwischen haben wir ja bereits einige numerische Integrationsverfahren kennengelernt. Die zugrundeliegende Frage ist stets: Wie groß ist die Fläche unter einer bestimmten Funktionskurve y=f(x) zwischen den x-Grenzen a und b ? In der Praxis hat man allerdings nur y-Meßwerte zu bestimmten x-Achsenwerten, kennt also die zugrundeliegende mathematische Funktion nicht wirklich. Fast genial erscheint daher die Idee, das Gummilineal der Mathematik, die Polynomfunktion in die Meßpunkte einzupassen und anschließend zu Integrieren. Das geht, weil nämlich das Integral eines Polynoms formelmäßig sehr gut bekannt ist. Bloß die entsprechenen Koeffizienten fehlen noch - doch da können Kapazunder wie Kepler, Euler, Gauss, Lagrange, Cotes oder eben auch der Schottisch-Britische Mathematiker, Astronom und Universitätsrektor Sir David Gregory (1659-1708), ein Zeitgenosse Newtons, helfen - und zwar gründlich: Die von ihm verwendeten Formeln sind vom Grad her einstellbar, sodaß er die Verfahren aller vorgenannter Herren beliebig emulieren kann. Weiters sind seine Koeffizientenformeln als Gewichte eines iterativen Verfahrens leicht implementierbar. Na dann los!
Gruss
P.S.: Mathematische interessanter mögen Lagrange- und Tschebeyschow-Polynome sein, aber nicht praxisgerechter. Lediglich das bereits behandelte Romberg-Verfahren erscheint noch einen Tick eleganter!
WindowTitle " GREGORY-INTEGRATION einer eingebauten Testfunktion x^n "
WindowStyle 24:Window 0,0-%maxx,%maxy-40:font 0:set("decimals",17)
'---------------------------------------------------------------------
' (C) ACM-TOMS ALGORITHM 280, COLLECTED ALGORITHMS FROM ACM.
' THIS WORK PUBLISHED IN COMMUNICATIONS OF THE ACM,
' VOL. 9, NO. 4, April, 1966, P. 271
'---------------------------------------------------------------------
' (D) Demo-Migration von C++ nach XProfan11.2a 2014-11
' by P.Specht, Wien (Austria). OHNE JEDE GEWÄHR!
'---------------------------------------------------------------------
'------------------------------------------------------------------------
' Programmanpassungen für Arraygröße und zu integrierende Funktion
'------------------------------------------------------------------------
Var nmax&=100 ' Verfahren ausgelegt für diese maximalen Arraygrößen
Proc Fn_PowN :parameters a!,n&
' y=x^n
case n&=0:return 1
if n&>0 : var x!=a!
whileloop n&-1
x!=x!*a!
endwhile
return x!
else
Print " Negativer Exponent in Fn_PowN nicht erlaubt!"
beep:waitinput 20000:return 0
endif
EndProc
'------------------------------------------------------------------------
'------------------------------------------------------------------------
Proc Gregory :parameters n&,r&,t![],w![] 'findet Gewichtungskoeffizienten
' Computes the abscissas and weights of the Gregory quadrature rule
' with r differences: Given h = (t_n - t_0)/n, then holds:
' Integral_from t_0 to t_n of: f(t) dt =~
' h*(f_0/2 + f_1 + ... +f_n-1 + f_n/2 )
' - h*12*( nabla(f_n) - delta(f_0) )
' - h*24*( nabla^2(f_n) + delta^2(f_0))
' - ...
' - h*c[r+1] *( nabla^r*f(n) + delta^r*(f_0) )
'= Sum[j=0..n]of w[j]*f(t[j])
'where h = (t_n - t_0)/n, and the c_j' are given in Henrici (1964, Schweiz & USA)
'The number r must be an integer from 0 to n, the number of subdivisions.
'The left and right endpoints must be in t(0) and t(n) respectively.
'The abscissas are returned in t(0) to t(n) and the corresponding weights
'in w(0) to w(n).
'
'If r=0 the Gregory rule is the same as the repeated trapezoid rule, and
'if r=n the same as the Newton-Cotes rule (closed type). The order p of the
'quadrature rule is p = r+1 for r odd and p = r+2 for r even.
'For n >= 9 and large r some of the weights can be negative.
'
'For n <= 32 and r<= 24, the numerical integration of powers (less than r)
'of x on the interval [0,1] gave 9 significant digits correct in an 11
'digit mantissa.
'
'2 References:
'Hildebrand, F. B. Introduction to Numerical Analysis.
'McGraw-Hill, New York 1956, p. 155 ;
'Henrici, Peter. Elements of Numerical Analysis.
'Wiley, New York 1964, p. 252.
'Person: http://en.wikipedia.org/wiki/Peter_Henrici_%28mathematician%28 : The Book:
'https://ia700700.us.archive.org/23/items/ElementsOfNumericalAnalysis/Henrici-ElementsOfNumericalAnalysis.pdf
'--------------------------------------------------------------------
Declare i&,j&,h!,cj!,c![nmax&+1],b![nmax&]
b![0]=1:b![n&]=0
c![0]=1:c![1]=-0.5
w![0]=0.5:w![n&]=w![0]
h!=(t![n&]-t![0])/n&
whileloop n&-1:i&=&Loop:
w![i&]=1
b![i&]=0
t![i&]=i&*h!+t![0]
endwhile
case r&>n&:r&=n&
Whileloop r&:j&=&Loop
cj!=0.5*c![j&]
whileloop j&,1,-1:i&=&Loop
b![i&]=b![i&]-b![i&-1]
endwhile
whileloop 3,j&+2:i&=&Loop
cj!=cj!+c![j&+2-i&]/i&
endwhile
c![j&+1]=-cj!
whileloop 0,n&:i&=&Loop
w![i&]=w![i&]-cj!*(b![n&-i&]+b![i&])
endwhile
Endwhile
WhileLoop 0,n&:i&=&Loop
w![i&]=w![i&]*h!
endWhile
EndProc 'Gregory
'--------------------------------------------------------------------
' Testteil
'--------------------------------------------------------------------
declare t![nmax&],w![nmax&]:declare I!,In!,i&,n&,r&,p&:declare a!,b!
a!=-1.0 'Integration von a
b!= 1.0 'bis b
n&= 7 'Grad des impliziten Polynoms
r&=n&
t![0]=a!:t![n&]=b! ' Integrationsgrenzen belegen
Gregory(n&,r&,t![],w![]) ' Polynom-Koeffizienten (Gregory-Gewichtungen) berechnen
' Kontrollausgabe:
font 2:Print "\n Gregory-Gewichtungen:\n "+mkstr$("-",40)
WhileLoop 0,n&:i&=&Loop
print tab(2);if(w![i&]<0,""," ");format$("%g",w![i&]),
print tab(27);if(t![i&]<0,""," ");format$("%g",t![i&])
endwhile:print
'-----------------------------------------------------------------------
' Testanwendung: Integriere die Funktion x^p und gib die Ergebnisse aus:
'-----------------------------------------------------------------------
whileloop 0,r&+4:p&=&Loop
I!= ( Fn_PowN(b!,p&+1) - Fn_PowN(a!,p&+1) ) / (p&+1)
In!=0
whileloop 0,n&:i&=&Loop
In!=In!+w![i&]*Fn_PowN(t![i&],p&)
endwhile
print tab(2);n&,tab(5);r&,tab(8);p&,
print tab(13);if(I!<0,""," ");format$("%g",I!),
print tab(43);if(In!<0,""," ");format$("%g",In!),
print tab(73);if((I!-In!)<0,""," ");format$("%g",I!-In!)
Endwhile
BEEP
Print "\n Es folgen die Vergleichsdaten lt. Buch [Taste]\n"+mkstr$("-",80)
waitinput
var wdata$=\
" 0.086921 -1.000000 \n 0.414005 -0.714286 \n"+\
" 0.153125 -0.428571 \n 0.345949 -0.142857 \n"+\
" 0.345949 0.142857 \n 0.153125 0.428571 \n"+\
" 0.414005 0.714286 \n 0.086921 1.000000 \n"
var outdata$= "\n "+\
"7 7 0 2.000000 2.000000 4.440892e-16 \n "+\
"7 7 1 0.000000 -0.000000 1.110223e-16 \n "+\
"7 7 2 0.666667 0.666667 2.220446e-16 \n "+\
"7 7 3 0.000000 -0.000000 8.326673e-17 \n "+\
"7 7 4 0.400000 0.400000 1.665335e-16 \n "+\
"7 7 5 0.000000 -0.000000 8.326673e-17 \n "+\
"7 7 6 0.285714 0.285714 0.000000e+00 \n "+\
"7 7 7 0.000000 -0.000000 4.163336e-17 \n "+\
"7 7 8 0.222222 0.230297 -8.075245e-03 \n "+\
"7 7 9 0.000000 -0.000000 2.775558e-17 \n "+\
"7 7 10 0.181818 0.202532 -2.071405e-02 \n "+\
"7 7 11 0.000000 -0.000000 1.387779e-17"
font 2:print Wdata$,outdata$
waitinput
End
Alles anzeigen
Abt. Wenn Tasten ausrasten
==================
und die unvermeidliche Keyboard-Verschmutzung selbst nach stärkstem Staubsaugereinsatz (mit Unterleibchen vor dem Saugstutzen, um versehentlich herausgesaugte Tastenkappen nicht zu verlieren) dennoch die Kontaktgabe verweigert, dann ist es Zeit, die betroffenen Tastenfunktionen umzuleiten, etwa auf F-Tasten oder Numpad.
Da meine API-Kenntnisse von Null nicht wesentlich abweichen, hab ich mir zumindest für XProfan-Programme mit folgenem Machwerk mal Übersicht verschafft, was noch geht und was nicht. Später möchte ich dann zwei oder drei Wackelkontakte umgehen und eine mir unangenehme Belegung auf Gewohnt ändern - aber da muss ich wohl noch etwas mehr Grips in die Umschalt- und Sondertasten-Funktionen stecken. Einstweilen...
Gruss
WindowTitle "Kontrolle über alle Tasten inkl. Maus"
Windowstyle 24
CLS 'Window 0,0-%maxx,%maxy-40
Font 2
Repeat
print %mousepressed,%mousex,%mousey," ",
select %mousekey
caseof 1:print "Linke Maustaste",
caseof 2:print "Rechte Maustaste",
endselect
select %scankey
caseof 1:print "$01 Linke Maustaste VK_LBUTTON", '??
caseof 2:print "$02 Rechte Maustaste VK_RBUTTON", '??
caseof 3:print "$03 Strg-Unterbrechung VK_CANCEL",
caseof 4:print "$04 Mittlere Maustaste VK_MBUTTON",
caseof 8:print "$08 BackSpace VK_BACK",
caseof 9:print "$09 Tab-Taste VK_TAB",
caseof 12:print "$0C Entfernen VK_CLEAR",
caseof 13:print "$0D Return VK_RETURN",
caseof 16:print "$10 Shift VK_SHIFT",
caseof 17:print "$11 Strg VK_CONTROL",
caseof 18:print "$12 Alt / Menü VK_MENU",
caseof 19:print "$13 Pause VK_PAUSE",
caseof 20:print "$14 CapsLock VK_CAPITAL",
caseof 27:print "$1B Esc VK_ESCAPE",
caseof 32:print "$20 Space VK_SPACE",
caseof 33:print "$21 BildHoch VK_PRIOR",
caseof 34:print "$22 BildRunter VK_NEXT",
caseof 35:print "$23 Ende VK_END",
caseof 36:print "$24 Pos1 VK_HOME",
caseof 37:print "$25 Links VK_LEFT",
caseof 38:print "$26 Hoch VK_UP",
caseof 39:print "$27 Rechts VK_RIGHT",
caseof 40:print "$28 Runter VK_DOWN",
caseof 41:print "$29 Select VK_SELECT",
caseof 42:print "$2A Druck VK_PRINT",
caseof 43:print "$2B Execute VK_EXECUTE",
caseof 44:print "$2C Druck VK_SNAPSHOT",
caseof 45:print "$2D Einfg VK_INSERT",
caseof 46:print "$2E Entf VK_DELETE",
caseof 47:print "$2F Hilfe VK_HELP",
caseof 48:print "$VK_0",
caseof 49:print "VK_1",
caseof 50:print "VK_2",
caseof 51:print "VK_3",
caseof 52:print "VK_4",
caseof 53:print "VK_5",
caseof 54:print "VK_6",
caseof 55:print "VK_7",
caseof 56:print "VK_8",
caseof 57:print "VK_9",
caseof 65:print "VK_A",
caseof 66:print "VK_B",
caseof 67:print "VK_C",
caseof 68:print "VK_D",
caseof 69:print "VK_E",
caseof 70:print "$VK_F",
caseof 71:print "VK_G",
caseof 72:print "VK_H",
caseof 73:print "VK_I",
caseof 74:print "VK_J",
caseof 75:print "VK_K",
caseof 76:print "VK_L",
caseof 77:print "VK_M",
caseof 78:print "VK_N",
caseof 79:print "VK_O",
caseof 80:print "VK_P",
caseof 81:print "VK_Q",
caseof 82:print "VK_R",
caseof 83:print "VK_S",
caseof 84:print "VK_T",
caseof 85:print "VK_U",
caseof 86:print "VK_V",
caseof 87:print "VK_W",
caseof 88:print "VK_X",
caseof 89:print "VK_Y",
caseof 90:print "VK_Z",
caseof 91:print "VK_LWIN",
caseof 92:print "VK_RWIN",
caseof 93:print "VK_APPS",
caseof 96:print "VK_NUMPAD0",
caseof 97:print "VK_NUMPAD1",
caseof 98:print "VK_NUMPAD2",
caseof 99:print "VK_NUMPAD3",
caseof 100:print "VK_NUMPAD4",
caseof 101:print "VK_NUMPAD5",
caseof 102:print "VK_NUMPAD6",
caseof 103:print "VK_NUMPAD7",
caseof 104:print "VK_NUMPAD8",
caseof 105:print "VK_NUMPAD9",
caseof 106:print "NUMPAD VK_MULTIPLY",
caseof 107:print "NUMPAD VK_ADD",
caseof 108:print "NUMPAD VK_SEPARATOR",
caseof 109:print "NUMPAD VK_SUBTRACT",
caseof 110:print "NUMPAD(,) VK_DECIMAL",
caseof 111:print "NUMPAD(/) VK_DIVIDE",
caseof 112:print "VK_F1",
caseof 113:print "VK_F2",
caseof 114:print "VK_F3",
caseof 115:print "VK_F4",
caseof 116:print "VK_F5",
caseof 117:print "VK_F6",
caseof 118:print "VK_F7",
caseof 119:print "VK_F8",
caseof 120:print "VK_F9",
caseof 121:print "VK_F10",
caseof 122:print "VK_F11",
caseof 123:print "VK_F12",
caseof 124:print "VK_F13",
caseof 125:print "VK_F14",
caseof 126:print "VK_F15",
caseof 127:print "VK_F16",
caseof 128:print "VK_F17",
caseof 129:print "VK_F18",
caseof 130:print "VK_F19",
caseof 131:print "VK_F20",
caseof 132:print "VK_F21",
caseof 133:print "VK_F22",
caseof 134:print "VK_F23",
caseof 135:print "VK_F24",
caseof 144:print "VK_NUMLOCK",
caseof 145:print "VK_SCROLL",
caseof 160:print "VK_LSHIFT",
caseof 161:print "VK_RSHIFT",
caseof 162:print "VK_LCONTROL",
caseof 163:print "VK_RCONTROL",
caseof 164:print "Linke Alt VK_LMENU",
caseof 165:print "Rechte_Alt VK_RMENU",
caseof 186:print "Ü_UE",
caseof 187:print "Plus",
caseof 188:print "Semicolon",
caseof 189:print "UnderScore",
caseof 190:print "FullStop",
caseof 191:print "Number#",
caseof 192:print "Ö_OE",
caseof 219:print "Backslash",
caseof 220:print "ToThePowerOf",
caseof 221:print "Accent",
caseof 222:print "Ä_AE",
caseof 226:print "LessThan",
otherwise :print "?";%scankey,
endselect
waitinput
cls
until 0
Alles anzeigen
Abt. PIE-, ARC- und CHORD-TRAINER
=======================
Das nachstehende Progrämmchen soll den Umgang mit Pie, Arc und Chord-Befehlen etwas logischer machen. Das Beispiel in der Profan-Hilfe berücksichtigt z.B. nicht die gekippte Perspektive bei Tortendiagrammen. Im nachstenden Machwerk wird genau dafür Sorge getragen, daß die (z.B. Anteils-abhängigen) Winkel stets der angewendeten Perspektive (aka. "Kavalier-Riss") angepasst verlaufen. Angenehmer Nebeneffekt: Die Tortenstück-Seiten laufen nun auch bei sehr breiten, aber nur wenig hohen Diagrammen stets zum Mauscursor hin, was eine manuelle Eingabe enorm erleichtert.
Gruss
P.S.: Daß das Ding wahnsinnig viel zu wünschen über lässt, etwa Farb-, Füll- und Formänderungen, Beschriftungen u.v.a.m., ist klar. Aber immerhin, eine erste lästige (Formel-)Hürde ist nun geschafft.
WindowTitle "SIMPLER PIE-ARC-CHORD-TRAINER":WindowStyle 24:Window 0,0 - %maxx,%maxy
'(CL) CopyLeft 2014-11 by P.Specht, Wien. Ohne jedwede Gewähr!
print "\n Bedienung (Bitte keine Hochstelltaste verwenden!):"
print "\n 1. Maus auf *linke obere* Ecke des Darstellundrechtecks, 'M'-Taste für 'MERKEN'"
print "\n 2. Maus auf rechte untere Ecke des Darstellundrechtecks, 'R'-Taste für 'RECHTECK'"
print "\n Es wird die Mitte des Tortenstücks abgezeigt, weil diese nun feststeht."
print "\n 3. Winkellinie Maus zu Mittelpunkt gibt Startwinkel: 'V'-Taste für 'VON'"
print "\n 4. Winkellinie Maus zu Mittelpunkt gibt Stop-winkel: 'B'-Taste für 'BIS'"
print "\n Tortenstück wird gezeichnet."
print "\n 5. 'C' für 'CLS' = Clear Screen"
print "\n Viel Spass beim üben!\n"
var xh&=width(%hwnd):var yh&=height(%hwnd)
declare LOX&,LOY&,LUX&,LUY&,SX&,SY&,EX&,EY&,StartAngle!,StopAngle!,Kippwinkel!
Repeat
waitinput
case %key=27:end
'print %key
if %key=109
print "M";
LOX&=%mousex:LOY&=%mousey
endif
if %key=114
print "R";
usepen 0,2,rgb(0,255,0)
LUX&=%mousex:LUY&=%mousey
rectangle LOX&,LOY& - LUX&,LUY&
usepen 0,5,rgb(255,0,0)
moveto (Lox&+lux&)\2,(Loy&+luy&)\2
lineto (Lox&+lux&)\2+1,(Loy&+luy&)\2
endif
if %key=118
print "V";
SX&=%mousex:SY&=%mousey
endif
if %key=98
print "B";
EX&=%mousex:EY&=%mousey
usebrush 0,rgb(0,0,255)
usepen 0,5,rgb(255,0,0)
Kippwinkel! = arctan4( LUy&-LOy&, LUx&-LOx& )
StartAngle! = arctan4( Sx&-(LUx&+LOx&)/2 , (LUy&+LOy&)/2-Sy& )
StopAngle! = arctan4( Ex&-(LUx&+LOx&)/2 , (LUy&+LOy&)/2-Ey& )
' Gilt für Pie, Arc und Chord:
PIE LOX&,LOY& - LUX&,LUY&;\
(LUx&+LOx&+(LUx&-LOx&)*Cos(-StartAngle!)*cos(Kippwinkel!) )/2,\
(LUy&+LOy&+(LUy&-LOy&)*Sin(-StartAngle!)*sin(Kippwinkel!))/2;\
(LUx&+LOx&+(LUx&-LOx&)*Cos(-StopAngle!)*cos(Kippwinkel!))/2,\
(LUy&+LOy&+(LUy&-LOy&)*Sin(-StopAngle!)*sin(Kippwinkel!))/2
endif
case %key=99:cls
until 0
proc ArcTan4 :parameters x!,y!
var pi!=3.1415926535897932:var w!=0 '(CL)2014-01 P.Specht§gmx.at
if x!=0:if y!>0:w!=pi!*0.5:elseif y!<0:w!=pi!*1.5:else :w!=0:endif :return w!:elseif x!>0
if y!=0:w!=0:return w!:elseif y!>0:if x!>y!:w!=arctan(y!/x!):else :w!=pi!/2-arctan(x!/y!):endif
return w!:else :if x!<-y!:w!=pi!*1.5+arctan(x!/-y!):else :w!=2*pi!-arctan(-y!/x!):endif :return w!
endif :else :if y!>0:if x!>-y!:w!=pi!/2+arctan(-x!/y!):return w!:else :w!=pi!-arctan(y!/-x!)
return w!:endif :elseif y!<0:if x!<y!:w!=pi!+arctan(-y!/-x!):else :w!=pi!*1.5-arctan(-x!/-y!)
endif :return w!:else :w!=pi!:return w!:endif :endif :Print " ArcTan4 ERROR":waitinput:waitinput
endproc
Alles anzeigen
Abt. Singleton-Sort, ein speicherminimaler Teilsort für Integerarrays
===========================================
Zugegeben, heutzutage ist Speicherminimierung bei Rechnern kaum sinnvoll, bei Embeded Systems (Microprozessoen in Autos, Waschmaschinen etc.) wird allerdings immer noch grosser Wert darauf gelegt. Dazu hier ein ziemlich populärer Algorithmus, natürlich wie immer ohne Gewähr...
Gruss
P.S.: Enthält einen der einfachsten Pseudozufallsgeneratoren, die es gibt. Aus mathematischer Sicht grottenschlecht, für praktische Verhältnisse aber durchaus geeignet.
WindowTitle upper$("Singleton-Sort eines Integer-Vektors zwischen Index ii und jj")
' (D) DEMO TRANSLATION from Fortran77 to XProfan11.2a in 2014-11
' by P. Specht, Wien (Austria); Ohne jedwede Gewähr! No warranties whatsoever!
'*******************************************************************************
' An Efficient Algorithm for Sorting with Minimal Storage, by: R. C. Singleton
' ALGORITHM 347, COLLECTED ALGORITHMS FROM ACM.
' THIS WORK PUBLISHED IN COMMUNICATIONS OF THE ACM
' VOL. 12, NO. 3, March, 1969, PP.185--187.
'*******************************************************************************
' SORTS ARRAY A INTO INCREASING ORDER, FROM A(II) TO A(JJ).
' ORDERING IS BY ***INTEGER SUBTRACTION***, THUS FLOATING POINT
' NUMBERS MUST BE IN NORMALIZED FORM!
' ARRAYS IU(K) AND IL(K) PERMIT SORTING UP TO 2^(K+1)-1 ELEMENTS.
'*******************************************************************************
WindowStyle 24:font 2
Window 0,0-%maxx,%maxy
Proc SingletonSORT :parameters A&[],ii&,jj&
DECLARE iJ&,il&[16],iu&[16],j&,k&,l&,m&,t&,tt&
M& = 1
I& = II&
J& = JJ&
G5:
CASE I& >= J&: GOTO "G70"
G10:
K& = I&
IJ& = (J&+I&)/2
T& = A&[IJ&]
case A&[I&]<=T&:GOTO "G20"
A&[IJ&] = A&[I&]
A&[I&] = T&
T& = A&[IJ&]
G20:
L& = J&
case A&[J&] >= T& : GOTO "G40"
A&[IJ&] = A&[J&]
A&[J&] = T&
T& = A&[IJ&]
case A&[I&] <= T& : GOTO "G40"
A&[IJ&] = A&[I&]
A&[I&] = T&
T& = A&[IJ&]
GOTO "G40"
G30:
A&[L&] = A&[K&]
A&[K&] = TT&
G40:
L& = L& - 1
case A&[L&] > T& : GOTO "G40"
TT& = A&[L&]
G50:
K& = K& + 1
case A&[K&] < T& : GOTO "G50"
case K& <= L&: GOTO "G30"
case (L&-I&) <= (J&-K&): GOTO "G60"
IL&[M&] = I&
IU&[M&] = L&
I& = K&
M& = M& + 1
GOTO "G80"
G60:
IL&[M&] = K&
IU&[M&] = J&
J& = L&
M& = M& + 1
GOTO "G80"
G70:
M& = M& - 1
case M& = 0 : RETURN
I& = IL&[M&]
J& = IU&[M&]
G80:
case (J&-I&) >= II& : GOTO "G10"
case I& = II& : GOTO "G5"
I& = I& - 1
G90:
I& = I& + 1
case I& = J& : GOTO "G70"
T& = A&[I&+1]
case A&[I&] <= T& : GOTO "G90"
K& = I&
G100:
A&[K&+1] = A&[K&]
K& = K& - 1
case T& < A&[K&] : GOTO "G100"
A&[K&+1] = T&
GOTO "G90"
endproc
Proc RN ' uses seed&
declare k&,rn! : case seed&=0:seed=rnd()
'*******************************************************************************
' RN returns a unit single precision pseudorandom number.
'*******************************************************************************
'
' This routine implements the recursion
'
' seed = 16807 * seed mod ( 2^31 - 1 )
' rn = seed / ( 2**31 - 1 )
'
' The integer arithmetic never requires more than 32 bits, including a sign bit.
'
' If the initial seed is 12345, then the first three computations are
'
' Input Output RN
' SEED SEED
'
' 12345 207482415 0.096616
' 207482415 1790989824 0.833995
' 1790989824 2035175616 0.947702
'
' Modified: 11 August 2004, Author: John Burkardt
'
' Reference:
'
' Paul Bratley, Bennett Fox, L E Schrage,
' A Guide to Simulation,
' Springer Verlag, pages 201-202, 1983.
'
' Pierre L'Ecuyer,
' Random Number Generation,
' in: Handbook of Simulation,
' edited by Jerry Banks,
' Wiley Interscience, page 95, 1998.
'
' Bennett Fox,
' Algorithm 647:
' Implementation and Relative Efficiency of Quasirandom
' Sequence Generators,
' ACM Transactions on Mathematical Software,
' Volume 12, Number 4, pages 362-376, 1986.
'
' P A Lewis, A S Goodman, J M Miller,
' A Pseudo-Random Number Generator for the System/360,
' IBM Systems Journal,
' Volume 8, pages 136-143, 1969.
'
' Parameters:
'
' Input/output, integer SEED, the "seed" value, which should NOT be 0.
' On output, SEED has been updated.
'
' Output, real RN, a new pseudorandom variate,
' strictly between 0 and 1.
'
k& = seed& \ 127773
seed& = 16807 * ( seed& - k& * 127773 ) - k& * 2836
if seed& < 0
seed& = seed& + 2147483647
endif
' Although SEED can be represented exactly as a 32 bit integer,
' it generally cannot be represented exactly as a 32 bit real number'
rn! = seed& * val("4.656612875E-10")
return rn!
endproc
' MAIN tests SORT.
' Modified 04 January 2006 by John Burkardt
Print "\n\n TOMS347_PRB\n Test Singleton Sort, which sorts an integer vector ascending."
declare ii&,jj&
ii& = 1
jj& = 20
test01(ii&,jj&)
waitinput
ii& = 5
jj& = 18
test01(ii&,jj&)
print "\n TOMS347_PRB: Success - Normal end of execution!"
waitinput
end
Proc test01 :parameters ii&,jj&
'*******************************************************************************
' TEST01 tests SORT on a particular range of indices.
' Modified 04 January 2006 by John Burkardt
'*******************************************************************************
var n&=20
declare a&[n&],i&,rn!,seed&
Print "\n\n TEST01: Ascending sorts an integer vector."
Print " Here we sort entries II = ";ii&;" to JJ = ";jj&
seed& = 123456789
whileloop n& : i&=&Loop
a&[i&] = int(n&*RN(seed&))
endwhile
Print "\n Unsorted array:"
whileloop n&:i&=&Loop
print i&, a&[i&]
endwhile
SingletonSORT(a&[],ii&,jj&)
Print "\n Sorted array:"
whileloop n&:i&=&Loop
print i&, a&[i&]
endwhile
endproc
''TOMS347_PRB RESULTS OF Test SORT, which ascending sorts an integer vector.
'
'TEST01
' SORT ascending sorts an integer vector.
' Here we sort entries II = 1
' through JJ = 20
'
' Unsorted array:
'
' 1 4
' 2 19
' 3 16
' 4 11
' 5 8
' 6 1
' 7 5
' 8 2
' 9 0
' 10 12
' 11 1
' 12 8
' 13 8
' 14 15
' 15 15
' 16 0
' 17 17
' 18 7
' 19 1
' 20 0
'
' Sorted array:
'
' 1 0
' 2 0
' 3 0
' 4 1
' 5 1
' 6 1
' 7 2
' 8 4
' 9 5
' 10 7
' 11 8
' 12 8
' 13 8
' 14 11
' 15 12
' 16 15
' 17 15
' 18 16
' 19 17
' 20 19
'
'TEST01
' SORT ascending sorts an integer vector.
' Here we sort entries II = 5
' through JJ = 18
'
' Unsorted array:
'
' 1 4
' 2 19
' 3 16
' 4 11
' 5 8
' 6 1
' 7 5
' 8 2
' 9 0
' 10 12
' 11 1
' 12 8
' 13 8
' 14 15
' 15 15
' 16 0
' 17 17
' 18 7
' 19 1
' 20 0
'
' Sorted array:
'
' 1 4
' 2 19
' 3 16
' 4 11
' 5 0
' 6 0
' 7 1
' 8 1
' 9 2
' 10 5
' 11 7
' 12 8
' 13 8
' 14 8
' 15 12
' 16 15
' 17 15
' 18 17
' 19 1
' 20 0
Alles anzeigen
Abt. Links zu Statistik-Software
====================
Wikipedia: Liste von Statistik-Softwarepaketen
Homepage "Interactive Statistical Calculators" mit Liste von Online-Statistikrechnern(engl.)
Linkseite Freie Statistik-Softwarepakete
Excel AddOns für Statistik
Wiki-Link zur IMSL, einer kommerziellen Sammlung der meistgenutzten und sichersten Statistik-Subroutinen in Fortran, C / C++, C# und Phyton
Homepage von Statcon - freie wissenschaftliche Statistik-Softwarebibliothek (engl.)
Gruss
P.S.: Es gibt auch einen freien Clone PSPPdes bekannten grossen Statistiksoftwarepakets SPSS
Ausserdem ist für Spezialisten eventuell die makroprogrammierbare Statistiksprache R von Interesse!
Online-Verteilungsfunktionsrechner
Abt. Natürliche Zahlen in Primfaktoren zerlegen
=============================
Jede beliebige natürliche Zahl lässt sich in Primzahl-Faktoren zerlegen. Diese Tatsache ist Mathematikern unter dem von Gauss geprägten Begriff "Fundamentalsatz der Arithmetik" bekannt. Je größer die Zahl, um so quadratisch-überproportional zeitaufwändig wird diese Zerlegung aber, denn bisher wurde kein auch für riesige Ganzzahlen funktionierender rascher Faktorisierungsalgorithmus bekannt. Genau deshalb kann man ja damit wirksam Nachrichten verschlüsseln, denn nur derjenige, dem die Primfaktoren bekannt gegeben werden (z.B. einer von zwei großen Faktoren plus ein öffentlicher Schlüssel), der kann die Botschaft in vernünftiger Zeit wieder entschlüsseln.
Bei zu kleinen Zahlen ist eine Zerlegung jedoch in kurzer Zeit möglich, wie das nachstehende in XProfan-11 übersetzte Progrämmchen beweist.
Gruss
P.S.: Selbst heutige Supercomputer oder sogar Quantencomputer schaffen eine Zerlegung wirklich großer Zahlen nicht in militärisch interessanter Zeit (Wenn die Schlacht vorbei ist, hat nämlich niemand mehr was davon). Allerdings sollten wir die Findigkeit der Crypto-Experten nicht unterschätzen: Jemand hat z.B. vor einiger Zeit einen derartigen Code geknackt, in dem er ihn als DNA-Strang synthetisierte (Roboter!). Anschließend wurde dieser billionenfach geklont (heute kein Problem mehr, dauert ca. 19 Stunden) und schließlich durch Einsatz verschiedener Enzyme, die große Primzahlen kodieren 8O und sich an den Strang anlagern, die fehlende Zahl herausgefiltert - somit der Code geknackt
'WindowTitle upper$("Factorization of an integer number")
WindowTitle upper$("Faktorisierung von natürlichen Zahlen")
' *******************************************
'* Sample run: *
'* ? 394616 *
'* 2 2 2 107 461 *
'* ----------------------------------------- *
'* Ref.: "Mathématiques par l'informatique *
'* individuelle (1) par H. Lehning *
'* et D. Jakubowicz, Masson, Paris, *
'* 1982" *
'* ----------------------------------------- *
'* C++ version by J-P Moreau. *
'* (www.jpmoreau.fr) *
'* XProfan Version by P.Specht, Wien (AT) *
'* Ohne Gewähr! No warranty whatsoever! *
'* ----------------------------------------- ********
'* Gegenprüfungsmöglichkeit: *
'* http://de.numberworld.info/faktorisierungsRechner *
' ***************************************************
set("decimals",0):windowStyle 24:font 2
Declare d!,eps!,m!,n!,i!:eps!=0.000001
start:
Cls:print
rept:
'print " Integer number to be factorized ?: ";:input n!
print " Integerzahl, die in Primfaktoren zerlegt werden soll ?: ";:input n!
case n!<0:End
case n!=0:n!=4294967295
if n!>4294967295:print " *** Overflow Error ***\n" : goto "rept":endif
print " ";
e50:
d!=n!-2*intf(n!/2)
if (abs(d!)<eps!): print "2 ";: n!=n!/2: goto "e50":endif
e100:
d!=n!-3*intf(n!/3)
if abs(d!)<eps!:print "3 ";: n!=n!/3: goto "e100":endif
' // All Prime numbers >3 are of the form 6i-1 or 6i+1
m!=floor(sqrt(n!))+1
i!=6
while i!<(m!+1)
e150:
d!=n!-(i!-1)*intf(n!/(i!-1))
if (abs(d!)<eps!) :print i!-1,: n!=n!/(i!-1): goto "e150":endif
e200:
d!=n!-(i!+1)*intf(n!/(i!+1))
if (abs(d!)<eps!):print i!+1,: n!=n!/(i!+1): goto "e200":endif
i!=i!+6
endwhile
case (n!>1):print n!,
print
if %csrlin>32:waitinput :goto "start":endif
goto "rept"
END
'===================== Math2.inc ==========================================
proc Sgn :parameters x!:return (x!>0)-(x!<0):endproc
proc floor :parameters x!:case abs(x!)<(10^-35):return 0:case x!>0
return intf(x!):return (abs(x!-intf(x!)) < 10^-35)-intf(abs(x!-1)):endproc
proc ceil :parameters x!:return -1*floor(-1*x!):endproc
proc modf :parameters x!,y!:case abs(x!)<10^-35:return 0
case abs(y!)<10^-35:return x!:return sgn(y!)*abs(x!-y!*floor(x!/y!)):endproc
proc remn :parameters x!,y!:case abs(x!)<(10^-35):return 0
case abs(y!)<(10^-35):return x!:return sgn(x!)*abs(x!-y!*floor(x!/y!)):endproc
proc IsNeg :parameters x!:return byte(Addr(x!),7)&%10000000>>7:endproc
proc frac :parameters x!:var s!=sgn(x!):x!=abs(x!):x!=x!-round(x!,0)
case x!<0:x!=1+x!:return s!*x!:endproc
proc intf :parameters x!:var s!=sgn(x!):x!=abs(x!):x!=x!-frac(x!):return s!*x!
endproc
'============================================================================
Alles anzeigen
Abt. Altbewährte Algorithmensammlungen
==========================
Link: Programmpaket-Sammlung von John Burghardt: Astronomie & Mathematik in C#,C++, Fortran77, ...
Link: DMOZ, eine Sprachenvergleichende Programmsammlung (engl.)
Link: Programmsammlung der NOAA (US-Vermessungsamt, global tätig)
Link: Übersicht zu den TOP 30 Freeware Statistik-Software
Gruss
P.S.: Freeware für Gitarristen
Abt. Die Dorftrottel-Funktion :s2:
==================
Uni-Anfängern wird im ersten Mathe-Unterricht gerne die harmlos erscheinende Gleichung y=x^x vorgestellt, zusammen mit der schlichten Bitte, die Kursteilnehmer mögen doch so nett sein und diese Funktion bis zum nächsten Termin nach x aufzulösen. Studenten unterschätzen diese Aufgabe in der Regel gewaltig und erhalten so ihr erstes Aha!-Erlebnis. Ihren mathematischen Namen erhielt die Gleichung ebenfalls auf diese Weise: An Unis im anglikanischen Sprachraum werden die Erstsemestrigen üblicherweise "Sophomores" (altgriechisch etwa 'unbedarfter Dorftrottel') genannt, es handelt sich daher ganz offiziell um die sog. SOPHOMORE-Funktion: Y = X ^ X.
In der numerischen Praxis wird NICHT nach x umgestellt (= invertiert), sondern Newton-Raphson angesetzt. Um die nötige Anzahl Iterationen so nieder wie möglich zu halten sollte lediglich noch die Ableitung von x^x - y = 0 bekannt sein, und die ergibt sich regelgemäß zu x^x*(ln(x)+1). Den Rest erledigen dann die beiden genannten Herren.
Gruss
WindowTitle "Iterative Lösung der Sophomore-Gleichung Y=X^X"
WindowStyle 24:set("decimals",17):font 2:CLS:declare x!,y!,xneu!,i&
REPEAT :print "\n Y=X^X Ges: X für Y=?",:input y!
if y!<=0:print " Funktion hier nicht mehr reell-wertig!":beep:continue
elseif y!<0.7:print " Wert nicht im monoton aufsteigenden Ast der Funktion!"
beep:continue:endif:xneu!=10:i&=0
Repeat:inc i&:x!=xneu!
xneu!=x! - (x!^x!-y!)/(x!^x!*(ln(x!)+1))
until (abs(xneu!-x!)<(10^-15)) or (i&>2000)
if i&<=2000:print " x = ";x!," nach",i&,"Läufen. Probe: X^X= ";x!^x!
else : print " *** Error: Nicht konvergent! ***":beep:endif
UNTIL %key=27:END
Alles anzeigen
Abt. Unsauberes Schleifenverlassen in XProfan am Beispiel "Eisenbahnschienen verlegen"
=======================================================
Das nachstehende Programm generiert Listen von Längen und Längenvielfachen, die in eine Soll-Länge nahtlos passen. Es entspricht dem Fortran-77-Programm "Algorithmus 403" der ACM, die auch das Copyright dafür besitzt. Mir geht es hier um etwas anderes: Im Fortran-77-Source wird nämlich sogar eine Innenschleife unsauber verlassen - offenbar macht das in dieser Sprache nichts! Anders in XProfan, hier wären Steuerungsvariablen zu belegen und die Schleife(n) gefälligst sauber zu verlassen. Da meine Fortran-Übersetzungsmakros aber noch ziemlich 1:1 arbeiten, wurden hier weder Arrays angepasst (Arrays beginnen in Fortran mit Index 1), noch werden die geschilderten "Programmablauf-Bocksprünge" abgefangen. Ich bin nicht ganz sicher, wie lange das gut geht - irgendwann droht jedenfalls Stack-Overflow. Dennoch war ich überrascht, wie klaglos das Programm bei kleinen Eingabewerten arbeitet.
Gruss
P.S.: Bitte dennoch um VORSICHT!!!
WindowTitle upper$("Generator für non-permutative k-Tupel konstanter Elementesumme")
' (D) Demo-Translation to XProfan-11.2a in 2014-11 by P.Specht, Wien (at)
' No warranty whatsoever! Ohne jedwede Gewähr! Es bestehen Urheberrechte!
' TEST FÜR UNSAUBERES SCHLEIFENVERLASSEN. BITTE VORSICHT! CAREFUL, STICKY LOOP RETURNS!
' (C) by ACM: File 403.gz fortran-77 Program Cyrpy: Generate integer partitions
' Algorithm 403 collected algorithms from ACM
' Algorithm appeared in Comm. ACM, Vol. 14, No. 01, p.048
' Subroutine cyrpy (requested_Sum, k, x&[]_of_k_elements)
' This subroutine generates all k-tuples such that.....
' a) the sum of the k elements of the k-tuple is v,
' b) each of the elements is an integer greater than 0, and
' c) no k-tuple is a cyclic permutation of any other k-tuple.
' The k-tuple is stored in array x, with one element
' per array element. Each k-tuple is processed by the user
' (using the subroutine UProc) before the next k-tuple is
' generated. The Users subroutine process must not change the
' contents of the array x[].
'---------------------------------------------------------------
WindowStyle 24:Font 0:randomize:CLS (200+rnd(56),200+rnd(56),200+rnd(56))
print "\n Programm generiert alle möglichen Ladelisten für Stangenmaterial,"
print " dessen Länge ein ganzzahliges Vielfaches einer Längeneinheit '1' "
print " ist und auf einen Transportwagen der Ladelänge Q lückenlos passt,"
print "\n oder z.B. alle Möglichkeiten, mit Modellbahn-Schienensystemen- "
print " mit Längenvielfachen Schienen einer kleinsten Basisschiene eine "
print " gegebene Streckenlänge Q zu bauen. Der Einbau-Ort der jeweiligen "
print " Schiene der Länge L ist dabei egal, der Algorithmus liefert nur "
print " eine Elementeliste, nicht alle deren mögliche Anordnungen! \n"
'---------------------------------------------------------------
Begin:
var k&=9 ' Anzahl Elemente des Tupels ('Pakete'),
var q&=15 ' deren Quersumme Q& betragen soll ('Gesamtlänge')
print "\n ANZAHL DER ELEMENTE ?: ";:input k&
print "\n ZU ERREICHENDE SUMME?: ";:input q&
WindowTitle upper$("Generator für non-permutative k-Tupel mit konstanter Elementesumme = "+str$(Q&))
declare x&[k&] ' Elemente-Array 1..k&
declare count& ' Zähler für Ausgabezeile
CLS:Font 2
'---------------------------------------------------------------
Cypry(q&,k&,x&[]) ' Aufruf der proc, die dann je Tupel die user-proc UProc aufruft
beep:print "\n-----------------------"
waitinput ' Fertig!
End
proc UProc :parameters x&[],k&
' Beispiel für die User-Proc (Hier nur Ausgabe von x[]).
' The User subroutine must not change the contents of x&[].
inc count&
print tab(3);"(";count&;").",tab(12);
whileloop 1,k&
print x&[&loop];" ";
endwhile:print
' if %csrlin>33:waitinput 2000:locate 1,1:endif
endproc
'---------------------------------------------------------------
Proc CYPRY :parameters v&,k&,x&[]
declare v1&, v2&, c&, sum&, k1&,k2&,i&,i1&,i2&
v1&=v&-k&+1
v2&=v&\k&
k1&=k&-1
k2&=k&-2
sum&=k1&
whileloop k1&:i&=&loop
x&[i&]=1
endwhile
goto "gg115"
' Generate the next k-tuple which satisfies the given conditions a) - c).
gg110:
c&=1
sum&=x&[1]
whileloop k2&:i&=&loop
i1&=k&-i&
x&[i1&]=x&[i1&]+c&
case x&[i1&]<v1&:goto "gg111"
x&[i1&]=x&[1]
goto "gg112"
gg111:
c&=0
gg112:
sum&=sum&+x&[i1&]
endwhile
case c&=0:goto "gg115"
x&[1]=x&[1]+1
case x&[1]>v2&:RETURN
whileloop 2,k1&:i1&=&loop
x&[i1&]=x&[1]
endwhile
sum&=x&[1]*k1&
v1&=v&-sum&
gg115:
sum&=v&-sum&
case sum&<x&[1]:goto "gg110"
x&[k&]=sum&
' Check to see if the k-tuple is a cyclic permutation of
' any previously generated k-tuples. If so, generate the
' next candidate, otherwise call the user-subroutine 'proces'
' to process the k-tuple before generating the next one.
whileloop 2,k&:i&=&loop
case x&[i&]>x&[1]:goto "gg122" ' überspringt Innenschleife: OK
case x&[i&]<x&[1]:goto "gg110" ' Unsauberes Verlassen der Schleife!
i1&=i&+1
whileloop 2,k&:i2&=&loop
case i1&>k&:i1&=i1&-k&
case x&[i1&]>x&[i2&]:goto "gg122" 'Unsauber!
case x&[i1&]<x&[i2&]:goto "gg110" 'Unsauberes verlassen von 2 Schleifen!!!
inc i1&
endwhile
goto "gg130"
gg122:
endwhile
gg130:
Uproc(x&[],k&) ' Aufruf der User-Proc je gültigem Tupel
goto "gg110"
endproc
Alles anzeigen
Abt. Berechnete Fortran-GO TO -Adresse in XProfan emulieren
========================================
In BASIC gab's das auch, als ON x GOTO <1>,<2>,<3>. Will man nicht gleich SELECT / ENDSELECT bemühen, gäbe es folgende +/- 1:1-Möglichkeit:
Abt. Die Vorzeichen-bedingte Verzweigung if i&,(100,200,300) von Fortran emulieren
=======================================================
CLS : Declare i&
WhileLoop -8,8,4:i&=&Loop
'If i&,(100,200,300) 'emulieren
Goto If(i&<0,"100",If(i&=0,"200","300"))
100:
Print "Kleiner Null!":Goto "skip"
200:
Print "Gleich Null!":Goto "skip"
300:
Print "Grösser Null!"
skip:
EndWhile
WaitInput
Alles anzeigen
P.S.: Ein Vorteil der GOTO-Versionen besteht darin, daß sie ohne große Klimmzüge und Stackoperationen in Assembler umgesetzt werden können.
Abt. Türme von Hanoi (ein Rekursionstest für XProfan)
==================================
Wusstet Ihr, daß die 'Türme von Hanoi' eigentlich aus Frankreich stammen?
Gruss
WindowTitle upper$("Türme von Hanoi, rekursiv")
WindowStyle 24:Window 0,0-%maxx,240:randomize:font 2
print "\n Hinweis: Sind n Scheiben auf 3 Pfosten vorgegeben, so braucht man mindestens 2^n-1 Schritte."
print "\n Das Problem ist in dieser Aufbereitung beliebt, um den Unterschied zwischen einer "
print " rekursiven Darstellung [(x(1)=1 und x(n+1)=2*x(n)+1] und expliziter Darstellung [x(n)=2^n-1]"
print " einer Folge zu demonstrieren."
waitinput 5000
Print "\n Zur Geschichte der Problemstellung:\n"
Print " Der französische Mathematiker Édouard Lucas (1842-1891) erfand dieses Spiel "
Print " und verkaufte es als Spielzeug erstmals im Jahre 1883. Dazu dachte sich Lucas "
print " eine Geschichte aus: Hindupriester sollten auf Geheiß ihres Gottes Brahma "
print " 64 Scheiben umlegen. Dazu benötigten sie theoretisch mindestens 2^64-1 = "
print " 1.8*10 ^19 Züge. Wird in jeder Sekunde eine Scheibe umgelegt, so dauert das "
print " 580 Milliarden Jahre. Das Weltall ist derzeit 13,48 Mrd Jahre alt und wird "
print " den beschleunigten Expansionstod (Atome zerreissen kausal) vermutlich in ca."
print " 48 Mrd Jahren erleiden. Nehmen wir also vielleicht etwas weniger Scheiben...\n"
waitinput 5000
print " \n Eine nonrekursive Algorithmus-Variante scheint *für Menschen* überraschend einfach:\n"
print " Solange der Turm nicht vollständig bewegt wurde: "
print " - bewege die kleinste Scheibe einen Platz modulo 3 nach rechts *)"
print " - führe die einzig mögliche Bewegung einer nicht-kleinsten Scheibe aus.\n____\n"
print " *): Scheibenzahl ungerade? Ersetze 'rechts' durch 'links' \n"
print "\n Hier folgt aber eine rekursive Variante, um damit XProfan auszutesten."
declare n&,m&
print "\n\n\n Gewünschte Scheibenzahl ?:",:input n&
WindowTitle " TASTE Q für SCHNELL-LAUF DRÜCKEN "
cls
declare h&[3,n&],v&[3],z&
whileloop n& : h&[1,&Loop]=n&+1-&Loop : endwhile :
v&[1]=n&
m&=n&
show 1,2
waitinput 1000
hanoi(n&,1,2,3)
beep
waitinput
end
proc hanoi :parameters n&,von&,nach&,ueber&
if n&=1
move(von&,nach&)
elseif n&>1
hanoi(n&-1,von&,ueber&,nach&)
move(von&,nach&)
hanoi(n&-1,ueber&,nach&,von&)
endif
endproc
proc move :parameters von&,nach&
v&[nach&]=v&[nach&]+1
h&[nach&,v&[nach&]]=h&[von&,v&[von&]]
h&[von&,v&[von&]]=0:v&[von&]=v&[von&]-1
show von&,nach&
case %key<>113:waitinput 1000
endproc
proc Show :parameters von&,nach&
locate 1,1
inc z&
print " ";z&;":",von&;">";nach&;" "
print "------------------------"
case %key<>113:waitinput 1000
declare v&,w&
whileloop 1,3:v&=&Loop
print " ";v&;": ",
whileloop 1,m&
w&=&Loop
if h&[v&,w&]>0:print h&[v&,w&],
else :print ".",
endif
endwhile
print
endwhile
print "------------------------"
endproc
Alles anzeigen
Abt. Eine Vier_Pfosten-Variante von "Türme von Hanoi" (rekursiv)
=========================================
Naja, äh... Auf den Internetseiten von 'Stack Overflow' ist sogar eine Variante mit beliebig vielen Pfosten (Engl.:'Pegs') zu finden, allerdings in der eher ungewöhnlichen Sprache 'F#'. Sie benutzt dem Vernehmen nach den iterativen 'Frame-Stewart Algorithmus'.
Gruss
WindowTitle upper$("Türme von Hanoi mit 4 Pfosten, rekursiv")
WindowStyle 24:Window 0,0-%maxx,240:randomize:font 2
print "\n Hier eine rekursive Variante mit 4 Pfosten"
declare n&,m&
print "\n\n\n Gewünschte Scheibenzahl ?:",:input n&
WindowTitle " TASTE Q für SCHNELL-LAUF DRÜCKEN "
cls
declare h&[4,n&],v&[4],z&
whileloop n& : h&[1,&Loop]=n&+1-&Loop : endwhile :
v&[1]=n&
m&=n&
show 1,2
waitinput 1000
hanoi4(n&,1,4,3,2)
beep
waitinput
end
proc hanoi4 :parameters n&,von&,ueber&,ueber2&,nach&
if n&=1
move(von&,nach&)
elseif n&=2
move(von&,ueber&)
move(von&,nach&)
move(ueber&,nach&)
else
Hanoi4(n&-2,von&,ueber2&,nach&,ueber&)
move(von&,ueber2&)
move(von&,nach&)
move(ueber2&,nach&)
Hanoi4(n&-2,ueber&,von&,ueber2&,nach&)
endif
endproc
'proc hanoi :parameters n&,von&,nach&,ueber&
'if n&=1
' move(von&,nach&)
'elseif n&>1
' hanoi(n&-1,von&,ueber&,nach&)
' move(von&,nach&)
' hanoi(n&-1,ueber&,nach&,von&)
'endif
'endproc
proc move :parameters von&,nach&
v&[nach&]=v&[nach&]+1
h&[nach&,v&[nach&]]=h&[von&,v&[von&]]
h&[von&,v&[von&]]=0:v&[von&]=v&[von&]-1
show von&,nach&
case %key<>113:waitinput 1000
endproc
proc Show :parameters von&,nach&
locate 1,1
inc z&
print " ";z&;":",von&;">";nach&;" "
print "------------------------"
case %key<>113:waitinput 1000
declare v&,w&
whileloop 1,4:v&=&Loop
print " ";v&;": ",
whileloop 1,m&
w&=&Loop
if h&[v&,w&]>0:print h&[v&,w&],
else :print ".",
endif
endwhile
print
endwhile
print "------------------------"
endproc
Alles anzeigen
Abt. Mist in Action
===========
In der Meßtechnik gilt bekanntlich die Formel "Wer misst, misst Mist!". Da es also ohnehin egal ist, ob man das Endergebnis abwartet oder aber aus husch-pfusch 8O in ähnlichen Zeitabständen beiläufig ermitelten Zwischenwerten komplett unsicher und ungenau auf ein Daumen-mal-Pi()-Peilungsmäßig ungefähres Endergebnis schließt, kann man früher heimgehen und das Resultat dort mit folgendem Abschätz-Programm ermitteln. Gerichtsmediziner, die Leichentemperaturen messen, machen schließlich auch nix anderes. Man darf nur nicht vergessen, gegenüber jedermann Stein und Bein zu schwören , daß es sich um ein völlig korrekt gemessenes Endergebnis handelt .
Gruss
WindowTitle upper$("Natürlichen Grenzwert ermitteln")
'(C) 2014-11_ff by P.Specht@gmx.at; frei für private Verwendung, ansonsten bestehen Rechte Dritter!
WindowStyle 24:var wid&=380:var heig&=200:randomize
Window (%maxx-wid&)\2,(%maxy-heig&-wid&)\2 - wid&,heig&
declare v$,c0!,c1!,c2!,ce!,cez!,cen!:start:
cls rgb(200+rnd(56),200+rnd(56),200+rnd(56)):font 0
locate 2,2:print " Basismesswert (t= 0 [s]) = ";:input v$:c0!=val(v$)
locate 4,2:print " Messwert nach (t=1*dt[s]) = ";:input v$:c1!=val(v$)
locate 6,2:print " Messwert nach (t=2*dt[s]) = ";:input v$:c2!=val(v$)
locate 8,2:print mkstr$("-",40):font 2
locate 10,2:print " Strebwert bei (t=+-Inf[s])= ";
if (c0!=c1!) and (c1!=c2!):print format$("%g",c2!)
else :cen!=2*c1!-c0!-c2!
if cen!<>0:cez!=(c1!*c1!-c0!*c2!):ce!=cez!/cen!:print format$("%g",ce!)
else :print "Ohne Grenze!"
endif:endif:waitinput:goto "start"
Alles anzeigen
Abt. Auf der Suche nach Mr. Normschrift
==========================
1) Wikipedia-Artikel "Normschrift"
2) Kleine Linkliste zu (halbwegs) normgerechten Schriften z.B. für technische Zeichnungen:
Artikel Technisches Zeichnen - 'Normschrift'
Freie TTF-Fonts: CAT-FONTS von Peter Wiegel, dort etwa zum freien Download:
- die alte DDR-Normschrift nach TGL 31 034-1 und -2, bis auf die kyrillischen Schriftzeichen nahezu identisch mit der heutigen DIN 6776-Normschrift bzw. nunmehr DIN EN ISO 3098 (Microfilm-tauglich).
- Alte Norm DIN 1451 als freies TTF
- Legende und Hinweise zu den dort frei verfügbaren TTF-Fonts
Kommerzielle Normschrift (ca. 85 €, kommt z.B. mit AutoCAD): Link für Testzwecke (In Google per 'isocpeur.ttf' und 'isocpeui.ttf' zu finden. Bitte Urheberrechte beachten!)
Schulschriften: Wiki-Artikel
Österreich: "Druckschrift 95" und "Schulschrift 95" (Scripturähnlich, gedacht für Lehrkräfte); Hinweis: In Österreich ist das kleine 'a' anders, eher ein o mit kleinerem L unmittelbar dran! Da hilft leider auch keine Beinert-Matrix!
Gruss
P.S.: Die Schriftart sollte dann natürlich auch auf dem Zielsystem vorhanden sein. Im Zweifel also mitliefern, oder man kann (ab Win-7) die recht ähnliche "Swis721 WGL4 BT"-Schrift verwenden, oder noch besser gleich ARIAL - das gibt´s seit Win95-Zeiten
Abt. Neuere Enwicklungen um die 'Künstlichen Intelligenz'
====================================
1) Neuro-inspirierte Chiparchitekturen (IBM TrueNorth)
2) Wissenschaftlich fundierte Entscheidungen treffen (Natürlichsprachige Abfrage von Expertensystemen, IBM WATSON)
3) Automatisiertes Berechnen und Beweisen: Wolfram Alpha
4) Automatisiert massiv-paralleles Rechnen (Tihane-2 zum 4. mal ungeschlagen mit 33.86 PetaFLOps.
5) Einsatz von DNA-Chips wird Erkennungsrate von Krankheiten massiv steigern
6) Weiter-reichende RFID-Lesegeräte können gestohlene Autos orten (und was nicht noch alles!), RFID-Passwortpille geplant (Motorola)
7) WLAN-Antenne aus der Sprühdose schafft temporäre Verbindungen
56 Qbit-Quantencomputer von Fa- D-Wave für KI-Zwecke einsetzbar
9) Computer bauen sich per 3D-Druck Extremitäten und Sinnesorgane
10) Exoskelette ahnen Bewegungswünsche von querschnittgelähmten Personen und führen diese aus
11) Kontaktlinsen mit eingebautem Zoom-on-demand bringen 200% Scharfsichtigkeit
12) Weiteres KI-Ergebnis: Handy-Akkus, die Autofahrern Starthilfe geben könnten (Univ. of Illinois)
13) Fahrerlose Autos legen bisher schon 13.000 km unfallfrei zurück (Google)
14) Data Mining wird auch für kleine Betriebe erschwinglich, Big-Data-Erkenntnisse via Datenhandel
15) Neue Geschäftsmodelle bringen weitere Effizienzsteigerung der Wirtschaft
16) Regierungen setzen KI-Forscher auf Arbeitsplatz-Ermittlung (Matching) an.
17) Spekulanten, Oligarchen und ihre Think-Tanks nutzen systematisch ANGST, um noch reicher zu werden... Hoppla: Das gabs ja schon...
Gruss
Abt. Emulation von FORTRANs Multi-Parameterrückübergabe in XProfan
============================================
Die Sache ist eigentlich ganz einfach: Fortran verwendet normalerweise Parameterübergabe 'by reference', also durch Adressübergabe an das Unterprogramm. Wertänderungen ändern daher auch die Werte im aufrufenden Programm. Erst die neuesten Fortran-Versionen stellen als Übergabeverfahren auch "by value" zur Wahl, was ja auch für Objektorientierung und zugehörige Datenverkapselung nötig ist.
XProfan kennt Parameterübergabe 'by reference' ebenfalls - allerdings nur bei Arrays! Die Lösung lautet daher: Man kann übergebene einfache Fortran-Variablen durch 'Ein-Elementige Arrayvariablen' nachbauen. Das erspart riesengroße Sourcecode-Anpassungen und ermöglich die "Weiternutzung" bestehender umfangreicher Programmbibliotheken durch strukturell wenig anspruchsvolle Übersetzung einzelner Codeelemente (Test zum Übergabeverfahren anbei).
Gruss
Cls
Declare a![0],b&[0],c%[0],d#
a![0]=12.3456789 : b&[0]=1024 : c%[0]=2048 : d#=4444
d# = Retroparam(a![],b&[],c%[],d#)
Print a![0],b&[0],c%[0],d#
Waitinput
End
proc Retroparam
parameters u![],v&[],w%[],x#
u![0]=u![0]-1.23
v&[0]=v&[0]+1
w%[0]=w%[0]-1048
x#=x#-1111
return x#
endproc
Alles anzeigen
Abt. Trickonometrie :idea:
============
sin(x) = sqrt(1-cos(x)^2)
sin(x) = tan(x) / sqrt(1+tan(x)^2)
sin(x) = 1 / sqrt(1+cot(x)^2)
cos(x) = sqrt(1- sin(x)^2)
cos(x) = 1 / sqrt(1+tan(x)^2)
cos(x) = cot(x) / sqrt(1+cot(x)^2)
tan(x) = sin(x) / sqrt(1-sin(x)^2)
tan(x) = sqrt(1-cos(x)^2) / cos(x)
tan(x) = 1 / cot(x)
tan(x) = sin(x) / cos(x)
cot(x) = 1 / tan(x)
cot(x) = cos(x) / sin(x)
cot(x) = sqrt(1-sin(x)^2) / sin(x)
cot(x) = cos(x) / sqrt(1-cos(x)^2)
sin(x)^2 + cos(x)^2 = 1
sin(x)^2 = 1 - cos(x)^2
cos(x)^2 = 1 - sin(x)^2
sec(x)^2 - tan(x)^2 = 1
sec(x)^2 = 1 + tan(x)^2
sec(x)^2 = tan(x)^2 + 1
tan(x)^2 = sec(x)^2 - 1
csc(x)^2 - cot(x)^2 = 1
cot(x)^2 = csc(x)^2 - 1
csc(x)^2 = cot(x)^2 + 1
csc(x)^2 = 1 + cot(x)^2
sin(x)*csc(x) = 1
sin(x) = 1 / csc(x)
csc(x) = 1 / sin(x)
cos(x)*sec(x) = 1
cos(x) = 1 / sec(x)
sec(x) = 1 / cos(x)
tan(x)*cot(x) = 1
tan(x) = 1 / cot(x)
cot(x) = 1 / tan(x)
sin(x+y) = sin(x)*cos(y) + cos(x)*sin(y)
sin(x-y) = sin(x)*cos(y) - cos(x)*sin(y)
cos(x+y) = cos(x)*cos(y) - sin(x)*sin(y)
cos(x-y) = cos(x)*cos(y) + sin(x)*sin(y)
tan(x+y) = (tan(x)+tan(y)) / (1-tan(x)*tan(y))
tan(x-y) = (tan(x)-tan(y)) / (1+tan(x)*tan(y))
cot(x+y) = (cot(x)*cot(y) - 1) / (cot(y)+cot(x))
cot(x-y) = (cot(x)*cot(y) + 1) / (cot(y)-cot(x))
sin(x+y+z)=sin(x)*cos(y)*cos(z)+cos(x)*sin(y)*cos(z)+cos(x)*cos(y)*sin(z)-sin(x)*sin(y)*sin(z)
cos(x+y+z)=cos(x)*cos(y)*cos(z)-sin(x)*sin(y)*cos(z)-sin(x)*cos(y)*sin(z)-cos(x)*sin(y)*sin(z)
sin(2*x) = 2*cos(x)*sin(x)
sin(3*x) = 3*sin(x) - 4*sin(x)^3
sin(4*x) = 8*cos(x)^3*sin(x) - 4*cos(x)*sin(x)
sin(n*x) = n*cos(x)^(n-1)*sin(x) - BK(n,3)*cos(x)^(n-3)*sin(x)^3 + BK(n,5)*cos(x)^(n-5)*sin(x)^5 - ...
cos(2*x) = cos(x)^2 - sin(x)^2
cos(3*x) = 4*cos(x)^3 - 3*cos(x)
cos(4*x) = 8*cos(x)^4 - 8*cos(x)^2 + 1
cos(n*x) = cos(x)^n - BK(n,2)*cos(x)^(n-2)*sin(x)^2 + BK(n,4)*cos(x)^(n-4)*sin(x)^4 - ...
tan(2*x) = 2*tan(x) / (1-tan(x)^2)
tan(3*x) = (3*tan(x) - tan(x)^3) / (1-3*tan(x)^2)
tan(4*x) = (4*tan(x)-4*tan(x)^3) / (1-6*tan(x)^2+tan(x)^4)
cot(2*x) = (cot(x)^2-1) / (2*cot(x))
cot(3*x) = (cot(x)^3-3*cot(x)) / (3*cot(x)^2-1)
cot(4*x) = (cot(x)^4-6*cot(x)^2+1) / (4*cot(x)^3-4*cot(x))
sin(x/2) = sqrt((1-cos(x)) / 2)
cos(x/2) = sqrt((1+cos(x)) / 2)
tan(x/2) = sqrt((1-cos(x)) / (1+cos(x))
tan(x/2) = (1-cos(x)) / sin(x)
tan(x/2) = sin(x) / (1+cos(x))
cot(x/2) = sqrt((1+cos(x)) / (1-cos(x))
cot(x/2) = (1+cos(x)) / sin(x)
cot(x/2) = sin(x) / (1-cos(x))
sin(x)+sin(y) = 2*sin((x+y) / 2)*cos((x-y) / 2)
sin(x)-sin(y) = 2*cos((x+y) / 2)*sin((x-y) / 2)
cos(x)+cos(y) = 2*cos((x+y) / 2)*cos((x-y) / 2)
cos(x)-cos(y) = -2*sin((x+y) / 2)*sin((x-y) / 2)
tan(x)+tan(y) = sin(x+y)/(cos(x)*cos(y))
tan(x)-tan(y) = sin(x-y)/(cos(x)*cos(y))
cot(x)+cot(y) = sin(x+y)/(sin(x)*sin(y))
cot(x)-cot(y) = sin(x-y)/(sin(x)*sin(y))
sin(x)*sin(y) = (cos(x-y)-cos(x+y)) / 2
cos(x)*cos(y) = (cos(x-y)+cos(x+y)) / 2
sin(x)*cos(y) = (sin(x-y)+sin(x+y)) / 2
sin(x)*sin(y)*sin(z) = (sin(x+y-z)+sin(-x+y+z)+sin(x-y+z)-sin(x+y+z)) / 4
sin(x)*sin(y)*cos(z) = (-cos(x+y-z)+cos(-x+y+z)+cos(x-y+z)-cos(x+y+z)) / 4
sin(x)*cos(y)*cos(z) = (sin(x+y-z)-sin(-x+y+z)+sin(x-y+z)+sin(x+y+z)) / 4
cos(x)*cos(y)*cos(z) = (cos(x+y-z)+cos(-x+y+z)+cos(x-y+z)+cos(x+y+z)) / 4
sin(x)^2 = (1 - cos(2*x)) / 2
sin(x)^3 = (3*sin(x) - sin(3*x)) / 4
sin(x)^4 = (cos(4*x) - 4*cos(2*x) + 3) / 8
cos(x)^2 = (1 + cos(2*x)) / 2
cos(x)^3 = (cos(3*x) + 3*cos(x)) / 4
cos(x)^4 = (cos(4*x) + 4*cos(2*x) + 3) / 8
sin(x)^2*cos(x) = cos(x) - cos(x)^3
sin(x)*cos(x)^2 = sin(x) - sin(x)^3
sin(x)^2*cos(x)^2 = cos(x)^2 - cos(x)^4
Alles anzeigen
P.S.: BK(n,m)=Binomialkoeffizient; sec(x) = Secans; csc(x): Cosecans ; cot(x): Cotangens
Abt. Chancen der Augensummen beim Wurf zweier Würfel
====================================
Eine klassische Frage an Mathematiker, gestellt von spielsüchtigen französischen Grafen :s2: im 17. Jahrhundert, gab Anstoß zur Entwicklung der gesamten Spieltheorie Und die ist todernste kombinatorische Optimierung und hat so garnichts spielerisches. Sie untersucht mit wissenschaftlichen Mitteln die Chancen, in Wahlsituationen zu gewinnen - und zwar für alle beteiligten Seiten.
Gruss
WindowTitle "Zwei-Würfel-Augensummenstatistik":var s!=0:font 2
Windowstyle 24:cls:set("decimals",17):print "\n\n\n\n":whileloop 2,12
s!=val(substr$("0 0.02777777777777777 0.05555555555555555 0.08333333333333333 "+\
"0.1111111111111111 0.13888888888888888 0.16666666666666666 0.13888888888888888 "+\
"0.1111111111111111 0.08333333333333333 0.05555555555555555 0.02777777777777777",\
&Loop," "))
print tab(3);&Loop,tab(9);s!
print mkstr$(chr$(154),s!*450)
endwhile :waitinput
Sie haben noch kein Benutzerkonto auf unserer Seite? Registrieren Sie sich kostenlos und nehmen Sie an unserer Community teil!