Commit c0b01702 by kollo

version 1.15

parent 1cb182ce
' Demonstration DOOCS server. Run this with doocsxbasic.
' (c) Markus Hoffmann Aug. 2007
'
dim array(100)
ttt$()=["Mon","Din","Mit"]
a=1.111
b=2.234
information$="Herzlichen Glueckwunsch"
doocsexport a,b,cmd,status,status$,information$,array(),ttt$()
doocscallback a,mycall1,mycall2
' doocscallback b,mycall3
doocsserver "TESTSERVER"
for i=0 to 100
array(i)=i
next i
t=timer
do
print time$,a,b,(a-b)
exit if a=0.5
exit if a>800
pause 0.2
if timer-t>1
t=timer
a=0
b=a
endif
if a<>b
status$="Differenz !"
else
status$="OK"
endif
loop
quit
procedure mycall1
print "Write-Callback auf a",a
return
procedure mycall2
' print "Read-Callback auf a",a
inc a
return
procedure mycall3
print "Write-Callback auf b",b,a
return
schwarz=get_color(0,0,0)
weiss=get_color(65535,65535,0)
do
print "Wert: ";doocsget("TEST.DOOCS/LOCALHOST_8889/TRIGFUNCTION/SIN.AMPL")
print "String: <";doocsget$("TEST.DOOCS/LOCALHOST_8889/TRIGFUNCTION/SIN.AMPL");">"
a()=doocsget("TEST.DOOCS/LOCALHOST_8889/TRIGFUNCTION/SIN.TD")
b()=a(:,1)
color schwarz
pbox 0,0,640,400
color weiss
scope b(),1,10,200
print "Typ: ";doocstyp("TEST.DOOCS/LOCALHOST_8889/TRIGFUNCTION/SIN.AMPL")
print "Len: ";doocssize("TEST.DOOCS/LOCALHOST_8889/TRIGFUNCTION/SIN.AMPL")
print "Info: ";doocsinfo$("TEST.DOOCS/LOCALHOST_8889/TRIGFUNCTION/SIN.AMPL")
print "Info: ";doocsinfo$("TEST.DOOCS/LOCALHOST_8889/TRIGFUNCTION/SIN.TD")
tim=doocstimestamp("TEST.DOOCS/LOCALHOST_8889/TRIGFUNCTION/SIN.AMPL")
text 10,10,"Timestamp: "+str$(tim)+" "+unixtime$(tim)+" "+unixdate$(tim)
doocsput "TEST.DOOCS/LOCALHOST_8889/TRIGFUNCTION/SIN.AMPL",2.145
showpage
pause 0.1
loop
quit
29.08.06 19:16:04.699 CDT[*unknown*] TINE HOME : [/home/hoffmann/DESY/tine/database/]
29.08.06 19:16:04.701 CDT[*unknown*] Reserved 100 client connection link entries
29.08.06 19:16:04.702 CDT[*unknown*] Reserved 100 client connection addr entries
29.08.06 19:16:04.703 CDT[*unknown*] Control Structures Swap information registered
29.08.06 19:16:04.707 CDT[*unknown*] UDP PORT 0: bound to 8054 (socket 3 blocking)
29.08.06 19:16:04.708 CDT[*unknown*] joining globals multicast group : success
29.08.06 19:16:04.710 CDT[*unknown*] UDP PORT 8004: bound to 8004 (socket 4 blocking)
29.08.06 19:16:04.710 CDT[*unknown*] Attach SENDER PROPS (500 msec): SINGLE
29.08.06 19:16:04.711 CDT[*unknown*] UDP PORT 0: bound to 8055 (socket 5 blocking)
29.08.06 19:16:04.712 CDT[*unknown*] ENS: SENDER [FEC SENDER, EQP SENDER] added
29.08.06 19:16:04.717 CDT[*unknown*] joining multicast group : success
29.08.06 19:16:04.717 CDT[*unknown*] UDP PORT 9503: bound to 9503 (socket 6 blocking)
29.08.06 19:16:04.717 CDT[*unknown*] Attach SENDER MYPROP (100 msec): REFRESH
29.08.06 19:16:04.726 CDT[*unknown*] Attach SENDER PROPS (500 msec): SINGLE
29.08.06 19:16:04.728 CDT[*unknown*] Attach SENDER COUNT% (100 msec): REFRESH
29.08.06 19:16:04.729 CDT[*unknown*] Attach SENDER PROPS (500 msec): SINGLE
29.08.06 19:16:04.731 CDT[*unknown*] Attach SENDER BEAT (100 msec): REFRESH
29.08.06 19:16:04.731 CDT[*unknown*] Attach SENDER PROPS (500 msec): SINGLE
29.08.06 19:16:04.734 CDT[*unknown*] Attach SENDER STATUS$ (100 msec): REFRESH
29.08.06 19:21:52.463 CDT[*unknown*] TINE HOME : [/home/hoffmann/DESY/tine/database/]
29.08.06 19:21:52.467 CDT[*unknown*] Reserved 100 client connection link entries
29.08.06 19:21:52.468 CDT[*unknown*] Reserved 100 client connection addr entries
29.08.06 19:21:52.479 CDT[*unknown*] Control Structures Swap information registered
29.08.06 19:21:52.481 CDT[*unknown*] UDP PORT 0: bound to 8054 (socket 3 blocking)
29.08.06 19:21:52.482 CDT[*unknown*] joining globals multicast group : success
29.08.06 19:21:52.484 CDT[*unknown*] UDP PORT 8004: bound to 8004 (socket 4 blocking)
29.08.06 19:21:52.486 CDT[*unknown*] Attach SENDER PROPS (500 msec): SINGLE
29.08.06 19:21:52.491 CDT[*unknown*] UDP PORT 0: bound to 8055 (socket 5 blocking)
29.08.06 19:21:52.492 CDT[*unknown*] ENS: SENDER [FEC SENDER, EQP SENDER] added
29.08.06 19:21:52.505 CDT[*unknown*] joining multicast group : success
29.08.06 19:21:52.508 CDT[*unknown*] UDP PORT 9503: bound to 9503 (socket 6 blocking)
29.08.06 19:21:52.508 CDT[*unknown*] Attach SENDER MYPROP (100 msec): REFRESH
29.08.06 19:21:52.517 CDT[*unknown*] Attach SENDER PROPS (500 msec): SINGLE
29.08.06 19:21:52.530 CDT[*unknown*] Attach SENDER COUNT% (100 msec): REFRESH
29.08.06 19:21:52.537 CDT[*unknown*] Attach SENDER PROPS (500 msec): SINGLE
29.08.06 19:21:52.552 CDT[*unknown*] Attach SENDER BEAT (100 msec): REFRESH
29.08.06 19:21:52.558 CDT[*unknown*] Attach SENDER PROPS (500 msec): SINGLE
29.08.06 19:21:52.572 CDT[*unknown*] Attach SENDER STATUS$ (100 msec): REFRESH
Summary: Example basic program sourcefiles for X11-Basic
Vendor: Markus Hoffmann
Name: X11Basic-examples
Version: 1.14
Release: 2
Version: 1.15
Release: 1
Copyright: GPL
Group: Development/Languages
URL: http://x11-basic.sourceforge.net/examples/
......
' ######################################################################
' Erstellt eine Huffman tabelle (binaerbaum) fuer ein Alphabet und eine
' gegebene Haeufigkeitsverteilung. Das Alphabet und die
' Haeufigkeitsverteilung wird aus einem eingangsfile bestimmt.
' (c) Markus Hoffmann 2010
'
' Eigentlich ist es Shannon-Fano-Kodierung Binaerbaum
'
' Letzte Bearbeitung 03.02.2010
'
dim h(256),a(256)
dim t$(256)
arrayfill h(),0
h(0)=1 ! Das Ende Zeichen
count=0
gh=0
f$="huffman.bas"
if exist(f$)
open "I",#1,f$
content$=input$(#1,lof(#1))
l=len(content$)
for i=0 to l-1
a=peek(varptr(content$)+i) and 0xff
h(a)=h(a)+1
next i
endif
for i=0 to 255
if h(i)>0
inc count
gh=gh+h(i)
endif
a(i)=i
next i
for i=0 to 255
print i,h(i),a(i)
next i
sort h(),256,a()
'for i=0 to 255
' print i,h(i),a(i)
'next i
print "Das Alphabet besteht aus ";count;" Zeichen."
print "Gesamthaeufigkeit=";gh;"= Dateilaenge=";lof(#1)
print "char alphabet[";count;"]={";
flag=0
for i=255 downto 0
if h(i)>0
if flag
print ",";
endif
a=a(i)
if a>=32 and a<asc("z") and a<>34 and a<>asc("'")
print "'"+chr$(a)+"'";
else
print "0x"+hex$(a,2,2);
endif
flag=1
endif
next i
print "};"
print "char haufig[";count;"]={";
flag=0
for i=255 downto 0
if h(i)>0
if flag
print ",";
endif
print h(i);
flag=1
endif
next i
print "};"
@doit(0,count-1)
print "char *hufftable[]={"
for i=255 downto 255-count+1
print chr$(34)+t$(i)+chr$(34)+",",
a=a(i) and 0xff
if (a>=32 and a<=asc("z") and a<>34) or a=asc("{") or a=asc("}")
print chr$(34)+chr$(a)+chr$(34);
else if a=0
print "NULL";
else
print chr$(34)+"\"+oct$(a,3,3)+chr$(34);
endif
if i>255-count+1
print ",";
endif
print ,"/* ";str$(h(i)/gh*100,2,2);" % */"
next i
print "};"
' Jetzt die codierung
seek #1,0
kod$=""
for j=0 to l-1
a=peek(varptr(content$)+j) and 0xff
for i=0 to count-1
if a(255-i)=a
kod$=kod$+t$(255-i)
while len(kod$)>=8
kkk$=left$(kod$,8)
print kkk$;" ";
kod$=right$(kod$,len(kod$)-8)
wend
exit if true
endif
next i
if i=count
print "ERROR"
endif
next j
a=0
for i=0 to count-1
if a(255-i)=a
kod$=kod$+t$(255-i)
while len(kod$)>=8
kkk$=left$(kod$,8)
print kkk$;" ";
kod$=right$(kod$,len(kod$)-8)
wend
exit if true
endif
next i
if i=count
print "ERROR"
endif
print kod$
print "New Size: ";len(kod$)/8
print "Compression: ";len(kod$)/8/lof(#1)
print "Compression: ";len(kod$)/lof(#1);" Bits pro Zeichen. Soll:";log(count)/log(2)
close
quit
procedure doit(sta,sto)
local oo,x1,x2,i,hh,gh
x1=sta
x2=sto
clr gh,oo
if x2-x1=1
t$(255-x1)=t$(255-x1)+"1"
t$(255-x2)=t$(255-x2)+"0"
return
endif
for i=255-sta downto 255-sto
gh=gh+h(i)
next i
' print "gh=";gh
oo=gh
for i=255-sta downto 255-sto
oo=oo-h(i)
exit if oo<gh/2
next i
hh=255-i
' print "Halbierung bei ";x1;":";hh;":";x2
for i=x1 to hh
t$(255-i)=t$(255-i)+"1"
next i
for i=hh+1 to x2
t$(255-i)=t$(255-i)+"0"
next i
if hh>x1
@doit(x1,hh)
endif
if hh+1<x2
@doit(hh+1,x2)
endif
return
......@@ -6,4 +6,5 @@
510 Feb 28 00:13 <a href="randomminmax.bas">randomminmax.bas</a>
393 Feb 28 13:16 <a href="sieve.bas">sieve.bas</a>
314 Apr 1 1999 <a href="sqr.bas">sqr.bas</a>
314 Apr 1 1999 <a href="tsp.bas">tsp.bas</a> Traveling Salesman problem
</pre></body></html>
' Programm fuer Susan W. fuer Ihre Musiker-Tagungen
' (c) Markus Hoffmann Okt. 2004
dim day$(6),sym$(16),table(16,16),tut(16,4)
clr count
fbest=4711
cls
for i=0 to 15
read sym$(i)
next i
randomize
do
if count=0
if exist("susan.best")
@load("susan.best")
' @sofiset
else
@sofiset
' @randomset
endif
else
@verbessern
endif
inc count
arrayfill table(),0
arrayfill tut(),0
for j=0 to 5
a$=day$(j)
for i=0 to 15
a=peek(varptr(a$)+i)
tut(i,a-asc("0"))=tut(i,a-asc("0"))+1
for k=0 to 15
b=peek(varptr(a$)+k)
if b=a
table(i,k)=table(i,k)+1
endif
next k
next i
next j
f=0
for i=0 to 15
for j=0 to 3
if tut(i,j)<1
add f,1
endif
if tut(i,j)>2
add f,tut(i,j)-2
endif
next j
next i
for i=0 to 15
for j=i+1 to 15
if table(i,j)<1
add f,1
endif
if table(i,j)>2
add f,table(i,j)-2
endif
next j
next i
if f<=fbest
if f<fbest and count>1
beep
endif
print chr$(27);"[H";
@printit
print string$(45,"-")
print count;" ";timer;" ";int(timer-t);" ";"f=";f-8*3;" "
fbest=f
open "O",#1,"susan.best"
print #1,"# Zwischenergebnis von susan.bas (c) Markus Hoffmann"
print #1,"# date=";date$;" time=";time$;" F=";f-8*3
for h=0 to 5
print #1,day$(h)
next h
close #1
t=timer
if f=0
quit
endif
else
print "F= ";f;" ";fbest
if f-8*3>1.5*(fbest-8*3)
run
endif
endif
loop
quit
procedure verbessern
local ui,uj,i,j,f,oo
clr oo,f
print ">";
counter=random(64)+1
do
for i=0 to 15
for j=0 to 15
if table(i,j)=0 or table(i,j)>2 or (table(i,j)=2 and oo<>0) and (i mod 4)<>(j mod 4)
ui=i
uj=j
f=1
dec counter
endif
exit if counter=0
next j
exit if counter=0
next i
exit if counter=0
print "EXAUST:";counter,oo;
inc oo
loop
print "(";ui;" ";uj;") ";
flush
tag=-1
' finde den Tag
for i=0 to 5
d$=day$(i)
if peek(varptr(d$)+ui)=peek(varptr(d$)+uj)
tag=i
' print "Tag ";tag
endif
exit if tag<>-1
next i
if tag<>-1
' wir versetzen jetzt ui an einen anderen Tag wo ein Spieler
' gleichen Typs beim gleichen Tutor spielt
dd$=day$(tag)
tauschtag=-1
for i=0 to 5
d$=day$(i)
typ=(ui mod 4)
idx=(ui div 4)
if i<>tag
for j=0 to 3
if peek(varptr(d$)+j*4+typ)=peek(varptr(dd$)+ui) and j<>idx and peek(varptr(dd$)+j*4+typ)=peek(varptr(d$)+ui)
tauschtag=i
tauschidx=j
endif
exit if tauschtag<>-1
next j
endif
exit if tauschtag<>-1
next i
if tauschtag<>-1
print "<";tag;",";tauschtag;"> ";
flush
d$=day$(tauschtag)
a=peek(varptr(dd$)+ui)
b=peek(varptr(dd$)+tauschidx*4+typ)
c=peek(varptr(d$)+ui)
d=peek(varptr(d$)+tauschidx*4+typ)
poke varptr(dd$)+ui,b
poke varptr(dd$)+tauschidx*4+typ,a
poke varptr(d$)+ui,d
poke varptr(d$)+tauschidx*4+typ,c
day$(tauschtag)=d$
else
print "*TT-*";
flush
endif
day$(tag)=dd$
else
print "*t-*";
flush
endif
return
procedure printit
print " 1 2 3 4 5 6"
print day$(0)'day$(1)'day$(2)'day$(3)'day$(4)'day$(5)
print " 1 2 3 4 T"
print " A B C D A B C D A B C D A B C D : 1 2 3 4"
print " -----------------------------------------"
for i=0 to 15
print chr$(asc("A")+(i mod 4))'":"'
for j=0 to 15
if table(i,j)<1 or table(i,j)>2 and (i mod 4)<>(j mod 4)
print chr$(27);"[1m";
endif
print table(i,j)'
print chr$(27);"[m";
next j
print ":"'
for j=0 to 3
if tut(i,j)<1 or tut(i,j)>2
print chr$(27);"[1m";
endif
print tut(i,j)'
print chr$(27);"[m";
next j
print
next i
print string$(45,"-")
print "day Tut A Tut B Tut C Tut D"
print "---+--------+--------+--------+--------+"
for i=0 to 5
print i+1;" |";
d$=day$(i)
for j=0 to 3
for l=0 to 3
for k=0 to 3
if peek(varptr(d$)+4*k+l)=asc("0")+j
print chr$(asc("A")+l);str$(k+1);
endif
next k
next l
print "|";
next j
print
next i
return
' Permutationen von 4 Zahlen (Symmetrische Gruppe)
data 0123,0132,0213,0231,1023,1032,1203,1230,2103,2130,2013,2031,3120,3102,3210,3201
' Erzeugt zufaellige (aber gueltige) Verteilung
procedure randomset
global1=random(65536)
global2=random(65536)
global3=random(65536)
global4=random(65536)
global5=random(65536)
global6=random(65536)
day$(0)=@quintett$(global1)
day$(1)=@quintett$(global2)
day$(2)=@quintett$(global3)
day$(3)=@quintett$(global4)
day$(4)=@quintett$(global5)
day$(5)=@quintett$(global6)
return
' Erzeugt zufaellige Verteilung, bei der die Bedingung
' Fuer den Tutor erfuellt ist
procedure sofiset
local d$,i,a,j
d$=@quintett$(random(65536))
day$(0)=d$
for j=1 to 5
for i=0 to 15
a=(peek(varptr(d$)+i)-asc("0")+1) mod 4
poke varptr(d$)+i,a+asc("0")
next i
day$(j)=d$
next j
return
' Wandelt 16 Bit Integer-Zahl in ein Gueltiges Quartett/Quintett-Format
function quintett$(a)
local f$,t$,i,j,s$
t$=space$(16)
f$=hex$(a,4,4)
for i=0 to 3
a=val("0x"+chr$(peek(varptr(f$)+i)))
for j=0 to 3
s$=sym$(a)
poke varptr(t$)+i+j*4,peek(varptr(s$)+j)
next j
next i
return t$
endfunction
procedure load(f$)
local i
clr i
open "I",#1,f$
while not eof(#1)
lineinput #1,t$
if left$(t$)<>"#"
day$(i)=t$
inc i
endif
exit if i=6
wend
close #1
return
' Programmiert in X11-Basic Markus Hoffmann 2008
'
epsilon=-0.5
genauigkeit=1e-10 ! Geforderte Genauigkeit fuer theta
' for epsilon=-0.005 to -1.5 step -0.05
for x=0.0001 to 10 step 0.1
y=@theta(x)
print "tau=";x;" eps=";epsilon;" theta=";y;" +/- ";genauigkeit;" Abweichung(tau)=";x-@tau(y)
next x
' next epsilon
quit
' Dies ist die Funktion tau(theta)
function tau(theta)
if theta>=1
return -9999999
else
return theta+epsilon*ln(1-theta)
endif
endfunc
' Dies berechnet die Funktion theta(tau)
function theta(tau)
a=tau/(1-epsilon) ! Startwert ergibt sich aus der linearen Naeherung
increment=a/100 ! Anfangsintervall fuer die Schachtelung
if a>=1 ! Vorsicht: Die lin Naeherung ergibt werte >1
a=1-increment*3
endif
fehler=tau-@tau(a)
while abs(fehler)>genauigkeit and increment>1e-16
while fehler>0 and abs(fehler)>genauigkeit and a+increment<1
add a,increment
fehler=tau-@tau(a)
wend
increment=increment/2
while fehler<0 and abs(fehler)>genauigkeit
sub a,increment
fehler=tau-@tau(a)
wend
increment=increment/2
fehler=tau-@tau(a)
wend
return a
endfunction
' Traveling salesman problem
' This program generates a graph and trys to find a shortest route
' through it (c) Markus Hoffmann 2008
anzpoints=100
bw=400
dim x(anzpoints),y(anzpoints)
dim path(anzpoints)
dim ou(anzpoints)
arrayfill ou(),0
for i=0 to anzpoints-1
' x(i)=random(bw)
' y(i)=random(bw)
x(i)=(i mod 10)*bw/10+random(2)
y(i)=(i div 10)*bw/10+random(2)
' x(i)=(i mod 10)*bw/10
' y(i)=(i div 10)*bw/10
next i
c=0
ou(0)=1
for i=0 to anzpoints-1
nn=@neighbour(c)
path(c)=nn
ou(nn)=1
c=nn
next i
path(c)=0
@plotit
print @length
do
@perm(aa,bb)
@plotit
loop
quit
procedure perm(a,b)
return
procedure plotit
weiss=get_color(65535,65535,65535)
schwarz=get_color(0,0,0)
color schwarz
pbox 0,0,bw,bw
color weiss
for i=0 to anzpoints-1
' text x(i),y(i),str$(i)
pcircle x(i),y(i),2
next i
cc=0
for i=0 to anzpoints-1
print cc;"-->";
line x(cc),y(cc),x(path(cc)),y(path(cc))
cc=path(cc)
next i
line x(path(cc)),y(path(cc)),x(0),y(0)
vsync
return
function neighbour(a)
local i,b,n
' print "A:";a
n=a
gg=2*256
for i=0 to anzpoints-1
if ou(i)=0 and not a=i
b=@dist(a,i)
if b<gg
n=i
gg=b
' print n,gg
endif
endif
next i
return n
endfunction
function dist(ii,jj)
return sqrt((x(ii)-x(jj))^2+(y(ii)-y(jj))^2)
endfunction
function length()
local i,l,cc
cc=0
l=0
for i=0 to anzpoints-1
add l,@dist(cc,path(cc))
cc=path(cc)
next i
add l,@dist(path(cc),0)
return l
endfunction
......@@ -94,7 +94,7 @@ dim l$(15)
@text("Hallo")