Commit 3f0ea8b4 by kollo

version 1.19

parent 7b02fc54
' Calculates Surfaces of two hollow Balls and saves it into a file
' It then can be displayed with 3Dshow.bas
' (c) Markus Hoffmann 1990
PRINT "MAKE-WORLD (c) Markus Hoffmann"
meldung$="Surfaces of two hollow Balls"+chr$(0)
maxworld%=10000
mf%=maxworld%*13*8
world%=MALLOC(mf%)
maxworld%=mf%/13/8
PRINT
PRINT "Maxworld:"'maxworld%
'
'
x_1=-1
x_2=1
y_1=-1
y_2=1
z_1=-0.1
z_2=1
'
sx=0.05
sy=0.05
sz=0.1
'
CLR anzworld%
PRINT "Berechne Welt:"
PRINT "Koordinatenkreuz..."
' @add4fl(0,x_1,y_2,z_1/2,x_2,y_2,z_1/2,x_2,y_2,z_2/2,x_1,y_2,z_2/2)
' @add4fl(0,x_1,y_2,z_1/2,x_1,y_2,z_2/2,x_1,y_1,z_2/2,x_1,y_1,z_1/2)
PRINT "WWFkt."
' Auenkugel: Transparent
r=0.5
spsp=PI/15
st=PI/15
FOR phi=0 TO 2*PI STEP spsp
FOR theta=0.05 TO PI STEP st
PRINT chr$(13);"Flchen:"'anzworld%;
flush
@polar1(r,theta,phi)
@polar2(r,theta+st,phi)
@polar3(r,theta+st,phi+spsp)
@polar4(r,theta,phi+spsp)
@add4fl(0,x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4)
NEXT theta
NEXT phi
' Innenkukel: Solid
r=0.3
spsp=PI/10
st=PI/10
print
FOR phi=0 TO 2*PI STEP spsp
FOR theta=0.05 TO PI STEP st
PRINT chr$(13);"Flchen:"'anzworld%;
@polar1(r,theta,phi)
@polar2(r,theta+st,phi)
@polar3(r,theta+st,phi+spsp)
@polar4(r,theta,phi+spsp)
@add4fl(16,x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4)
NEXT theta
NEXT phi
print
'
PRINT "Welt: ";anzworld%;" Elemente..."
@saveworld
@ende
'
PROCEDURE polar1(r,th,ph)
x1=r*COS(ph)*SIN(th)
y1=r*SIN(ph)*SIN(th)
z1=r*COS(th)
RETURN
PROCEDURE polar2(r,th,ph)
x2=r*COS(ph)*SIN(th)
y2=r*SIN(ph)*SIN(th)
z2=r*COS(th)
RETURN
PROCEDURE polar3(r,th,ph)
x3=r*COS(ph)*SIN(th)
y3=r*SIN(ph)*SIN(th)
z3=r*COS(th)
RETURN
PROCEDURE polar4(r,th,ph)
x4=r*COS(ph)*SIN(th)
y4=r*SIN(ph)*SIN(th)
z4=r*COS(th)
RETURN
'
PROCEDURE add4fl(nu,x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4)
IF anzworld%<maxworld%
BMOVE varptr(x1),world%+anzworld%*104+0,8
BMOVE varptr(y1),world%+anzworld%*104+8,8
BMOVE varptr(z1),world%+anzworld%*104+2*8,8
BMOVE varptr(x2),world%+anzworld%*104+3*8,8
BMOVE varptr(y2),world%+anzworld%*104+4*8,8
BMOVE varptr(z2),world%+anzworld%*104+5*8,8
BMOVE varptr(x3),world%+anzworld%*104+6*8,8
BMOVE varptr(y3),world%+anzworld%*104+7*8,8
BMOVE varptr(z3),world%+anzworld%*104+8*8,8
BMOVE varptr(x4),world%+anzworld%*104+9*8,8
BMOVE varptr(y4),world%+anzworld%*104+10*8,8
BMOVE varptr(z4),world%+anzworld%*104+11*8,8
INC anzworld%
ENDIF
RETURN
PROCEDURE saveworld
FILESELECT "Welt abspeichern als ...","./*.xxx","welt.xxx",sa$
IF LEN(sa$)
open "O",#1,sa$
anzfl=anzworld%
sortstart=0
BPUT #1,VARPTR(meldung$),64
BPUT #1,VARPTR(anzfl),8
BPUT #1,VARPTR(sortstart),8
BPUT #1,world%,anzworld%*8*13
CLOSE #1
ENDIF
RETURN
'
PROCEDURE ende
FREE world%
quit
RETURN
dim width(128)
f$="grotlt.e24"
f$="normande.e24"
f$="/work/CDs/ATARI-ST_v_2/st/d/chsets/grotlt.p24"
open "I",#1,f$
d=10
clearw
seek #1,0
header$=input$(#1,140)
for i=0 to 128-1
width(i)=CVI(reverse$(input$(#1,4)))
next i
memdump varptr(header$),140
data$=input$(#1,lof(#1)-140-512)
wx=0
for c=1 to 63
@disp(wx,100,c)
next c
wx=0
for c=64 to 127
@disp(wx,200,c)
next c
keyevent
quit
procedure disp(x,y,c)
local o,w,h,d
o=width(c)
h=(width(c+1)-o)/2
d=peek(varptr(data$)+o)
w=peek(varptr(data$)+o+1)
w=peek(varptr(data$)+o+2)
text x,y+50,str$(w)
print peek(varptr(data$)+o+1),peek(varptr(data$)+o+3),w
print "char ";c;" offs=";d
add y,d
add o,4
sub h,2
for j=0 to h-1
a=peek(varptr(data$)+o+j*2)*256+(peek(varptr(data$)+o+1+j*2) and 255)
for i=0 to 15
if btst(a,i)
plot x+15-i,y
endif
next i
inc y
next j
vsync
add wx,w
return
' Displays Atari-ST 8*16 fixed Fonts (c) Markus Hoffmann
scale=2
text$="This example demonstrates the use of the old Atari-ST fonts!"+chr$(14)+chr$(15)+" We used "
color get_color(65535,65535,0)
COLOR GET_COLOR(65535,65535,0)
fileselect "FONT-Laden","./*.fnt","",f$
if len(f$)
if exist(f$)
open "I",#1,f$
text$=text$+f$
f$=input$(#1,4096)
close #1
for i=0 to 256
text$=text$+chr$(i)
next i
endif
@text(text$)
endif
endif
pause 10
quit
procedure text(t$)
local i
for i=0 to len(t$)-1
char=peek(varptr(t$)+i) and 255
@char(x,y,char)
vsync
pause 0.1
add x,8*scale
if x>=640
x=0
add y,16*scale
endif
next i
return
procedure char(x,y,c)
local i,j
for i=0 to 15
for j=0 to 7
if btst(peek(varptr(f$)+c+i*256),7-j)=0
pbox x+j*scale,y+i*scale,x+j*scale+scale,y+i*scale+scale-1
endif
next j
next i
return
FILESELECT "FONT-Laden","./*.fnt","",f$
IF LEN(f$)
IF EXIST(f$)
OPEN "I",#1,f$
text$=text$+f$
f$=INPUT$(#1,4096)
CLOSE #1
FOR i=0 TO 256
text$=text$+CHR$(i)
NEXT i
ENDIF
@text(text$)
ENDIF
PAUSE 10
QUIT
PROCEDURE text(t$)
LOCAL i
FOR i=0 TO LEN(t$)-1
char=PEEK(VARPTR(t$)+i) AND 255
@char(x,y,char)
VSYNC
PAUSE 0.1
ADD x,8*scale
IF x>=640
x=0
ADD y,16*scale
ENDIF
NEXT i
RETURN
PROCEDURE char(x,y,c)
LOCAL i,j
FOR i=0 TO 15
FOR j=0 TO 7
IF BTST(PEEK(VARPTR(f$)+c+i*256),7-j)=0
PBOX x+j*scale,y+i*scale,x+j*scale+scale-1,y+i*scale+scale-1
ENDIF
NEXT j
NEXT i
RETURN
f$="ST-fonts/spat-a.fnt"
OPEN "I",#1,f$
text$=text$+f$
f$=INPUT$(#1,4096)
CLOSE #1
scalex=31
scaley=22
a=ASC("s")
DO
CLEARW
@char(0,0,a)
COLOR GET_COLOR(65535,0,0)
FOR i=0 TO 10
LINE 10+0,50+i*20,10+10*20,50+i*20
NEXT i
FOR i=0 TO 10
LINE 10+i*20,50+0,10+i*20,50+200
NEXT i
DEFTEXT ,2,2
DEFLINE ,3
LTEXT 10,50,CHR$(a)
DEFLINE ,1
TEXT 300,200,STR$(a)
VSYNC
KEYEVENT
INC a
LOOP
PAUSE 10
QUIT
PROCEDURE char(x,y,c)
LOCAL i,j
color get_color(65535,65535,0)
FOR i=0 TO 15
FOR j=0 TO 7
IF BTST(PEEK(VARPTR(f$)+c+i*256),7-j)=0
PBOX x+j*scalex,y+i*scaley,x+j*scalex+scalex-1,y+i*scaley+scaley-1
ENDIF
NEXT j
NEXT i
RETURN
' Das fileformat:
' Byte 0 bis 7: "eset0001" (fuer e24 files) und "ps240001" beio P24 files
' Byte 8 bis 11: Long: Anzahl der Zeichen (normalerweise 128)
' byte 12 bis 139: ??
' Byte 140: long[anzchar] offsets
dim width(128)
f$="grotlt.e24"
f$="normande.e24"
f$="/work/CDs/ATARI-ST_v_2/st/d/chsets/amber.p24"
open "I",#1,f$
d=10
clearw
seek #1,0
header$=input$(#1,140)
for i=0 to 128-1
width(i)=CVI(reverse$(input$(#1,4)))
next i
memdump varptr(header$),140
data$=input$(#1,lof(#1)-140-512)
wx=0
for c=1 to 63
@disp(wx,100,c)
next c
wx=0
for c=64 to 127
@disp(wx,200,c)
next c
keyevent
quit
procedure disp(x,y,c)
local o,w,h,d
o=width(c)
h=(width(c+1)-o)/4
d=peek(varptr(data$)+o)
w=peek(varptr(data$)+o+1)
' w=peek(varptr(data$)+o+2)
text x,y+50,str$(w)
print peek(varptr(data$)+o+1),peek(varptr(data$)+o+3),w,
print "char ";c;" offs=";d
add y,d
add o,4
sub h,1
for j=0 to h-1
a=(peek(varptr(data$)+o+j*4) and 255)*256*256*256+(peek(varptr(data$)+o+1+j*4) and 255)*256*256+(peek(varptr(data$)+o+2+j*4) and 255)*256+(peek(varptr(data$)+o+3+j*4) and 255)
' a=(peek(varptr(data$)+o+0+j*4) and 255)*256+(peek(varptr(data$)+o+1+j*4) and 255)
for i=0 to 32
if btst(a,i)
plot x+15-i,y
endif
next i
inc y
next j
vsync
add wx,w
return
......@@ -10,7 +10,16 @@ for i=0 to 30
circle 320,200,i*5
next i
gprint "use the right mouse button to skip this dialog."
i=0
while len(param$(i))
inc i
wend
f$=param$(i-1)
print i,f$
if not exist(f$) or upper$(right$(f$,4))<>".RSC"
fileselect "load RSC...","./rsc/*.rsc","",f$
endif
rsrc_load f$
count=0
adr=rsrc_gaddr(15,count)
......
Summary: Example basic program sourcefiles for X11-Basic
Vendor: Markus Hoffmann
Name: X11Basic-examples
Version: 1.15
Version: 1.19
Release: 1
Copyright: GPL
Group: Development/Languages
......@@ -11,7 +11,11 @@ Packager: Markus Hoffmann <kollo@users.sourceforge.net>
%description
Thease are example programs for X11-Basic.
Thease are example programs for X11-Basic. Most of them can be easily run from
a text console, e.g. on UNIX/Linux systems. Not all of them are useful on
other platforms like WINDOWS or Android.
Have fun.
......
'
' smartpen.bas (c) Markus Hoffmann 2011
'
' demonstrated how one can use the data, which comes from a livescrive Smartpen
' Export a page as pdf. Then this program can read it.
' needs debian package: pstoedit
'
bw=930
bh=1080
top=850
sizew ,bw,bh
vsync
pause 0.1
clearw
vsync
' Fileneame to read :
in$="Smartpen-Demo.pdf"
if not exist(in$)
in$=param$(2)
endif
tmp$="/tmp/a.svg"
system "pstoedit "+in$+" "+tmp$
fluent=0
scale=1.5
open "I",#1,tmp$
entry:
bbcount=0
while not eof(#1)
lineinput #1,t$
if glob(t$,"*<polyline*")
t$=trim$(t$)
a$=word$(t$,2)
b$=word$(t$,3)
' print t$
split a$,"=",0,dummy$,a$
@drawline(a$)
pause 0.1
endif
wend
seek #1,0
inc fluent
if fluent>1
defline ,3
endif
color get_color(65535,30000,0)
if fluent<3
goto entry
endif
' system "convert 'bb*.bmp' a.mpg"
' system "rm -f bb*.bmp"
system "rm -f "+tmp$
pause 10
quit
procedure drawline(l$)
count=0
while len(l$)
split l$," ",0,p$,l$
# print p$
split p$,",",0,x$,y$
x=val(x$)*scale
y=(top-val(y$))*scale
if count=0
ox=x
oy=y
endif
line ox,oy,x,y
ox=x
oy=y
if fluent
vsync
' pause 0.01
endif
if fluent=0 and 0
get 100,200,320,200,bb$
inc bbcount
bsave "bb"+str$(bbcount,4,4,1)+".bmp",varptr(bb$),len(bb$)
endif
inc count
wend
vsync
return
' Zu Spektrum der Wissenschaft
' There is a scaling law on the first digit of random numbers
'
SIZEW ,11*10,400
DIM zl(10)
CLEAR
FOR I=0 TO 9
TEXT i*10,10,STR$(i)
NEXT i
DO
INC c%
z%=RANDOM(RANDOM(10000))
ziff%=VAL(LEFT$(STR$(z%)))
INC zl(ziff%)
' print zl(ziff%)
COLOR 0
LINE ziff%*10,400,ziff%*10,16
COLOR get_color(65535,0,0)
LINE ziff%*10,zl(ziff%)/c%*600+16,ziff%*10,16
TEXT 50,380,STR$(c%)
VSYNC
PAUSE 0.01
LOOP
QUIT
print "\documentclass[12pt,a4paper,dvips,openany,final]{scrartcl}"
print "\begin{document} "
print "\subsection*{dB Tabelle}"
print "\begin{tabular}{|r|cc|}"
print "\hline"
print "{\bf dB} & {\bf Amplitude} & {\bf Leistung}\\"
print "\hline"
db=-90
do
print str$(db,5,5);" & ";str$(10^(db/20),6,3);" & ";str$(10^(db/10),6,3);" \\"
add db,10
exit if db>60
loop
print "\hline"
print "\end{tabular}"
print "\begin{tabular}{|r|cc|}"
print "\hline"
print "{\bf dB} & {\bf Amplitude} & {\bf Leistung}\\"
print "\hline"
db=-10
do
print str$(db,5,5);" & ";str$(10^(db/20),6,3);" & ";str$(10^(db/10),6,3);" \\"
add db,1
exit if db>10
loop
print "\hline"
print "\end{tabular}"
print "\end{document}"
quit
......@@ -61,13 +61,18 @@ PROCEDURE init
lila=get_color(65530,0,65530)
blau=get_color(10000,10000,65530)
gruen=get_color(0,30000,0)
bx=0
by=16
by=0
bw=640
bh=384
bh=400
get_geometry 1,bx,by,bw,bh
add by,16
sub bh,bx
color weiss
pbox bx,by,bx+bw,by+bh
color schwarz
color schwarz,weiss
RESTORE menudata
FOR i=0 TO 80
read t$
......@@ -83,7 +88,14 @@ PROCEDURE init
RESTORE px_data
READ pkoxv,pkoxb,pkox_v,pkox_b,pkorwx,pkorwx_
RESTORE py_data
READ pkoyv,pkoyb,pkoy_v,pkoy_b,pkorwy,pkorwy_
goto aaa
aaa:
READ pkoyv
READ pkoyb
READ pkoy_v
READ pkoy_b
READ pkorwy
READ pkorwy_
RETURN
procedure n
~form_alert(1,"[3][Funktion nicht implementiert !][ OH ]")
......@@ -325,7 +337,7 @@ PROCEDURE pkoordinate(tx$,ty$)
TEXT @px(0)-8*LEN(ty$)-8,@py(pkod)+8,ty$
RETURN
PROCEDURE m(k)
print k
' print k
on k gosub info
on k-10 gosub load.dgl,save.dgl,n,load,save,clear,n,delete,n,ende
on k-22 gosub vfeldxn,vfeldxp,n,vfeldyn,@vfeldyp,n,ox,oy,rennenx,renneny
......@@ -385,12 +397,12 @@ PROCEDURE ende
RETURN
PROCEDURE info
~form_alert(1,"[0][DIFFGLEI.BAS |(c) Markus Hoffmann][ OK ]")
~form_alert(1,"[0][DIFFGLEI.BAS |Spiel mit Differentialgleichungen.|(c) Markus Hoffmann][ OK ]")
RETURN
PROCEDURE koordin
LOCAL xU,yU,wU,hU,fdoretU,b$
'
~@rsrc_gaddr(0,koordin__U,dialogadr%)
~rsrc_gaddr(0,koordin__U,dialogadr%)
~FORM_CENTER(dialogadr%,xU,yU,wU,hU)
' ~FORM_DIAL(0,0,0,10,20,xU,yU,wU,hU)
~FORM_DIAL(1,0,0,10,20,xU,yU,wU,hU)
......@@ -429,7 +441,7 @@ RETURN
PROCEDURE koordin2
LOCAL xU,yU,wU,hU,fdoretU,b$
'
~@rsrc_gaddr(0,koordin2__U,dialogadr%)
~rsrc_gaddr(0,koordin2__U,dialogadr%)
~FORM_CENTER(dialogadr%,xU,yU,wU,hU)
' ~FORM_DIAL(0,0,0,10,20,xU,yU,wU,hU)
~FORM_DIAL(1,0,0,10,20,xU,yU,wU,hU)
......
'
' Finanzierung.bas (c) Markus Hoffmann 2007-2010
'
' berechnet bei gegebenem Zinssatz und gewuenschter
' monatlicher Zahlung (Tilgunk+Zinsen) und optional jaerhlichen
' Extratilgungen die Kreditlaufzeit in Abhaengigekeit von der
' Kreditsumme.
'
' Effektiver Jahreszinssatz f"uer den Kredit
zinssatz=5.4/100
' Monatliche Rueckzahlung
belastung=1100
' Extra-Tilgung am Jahresende
extratilgung=00
tmp$="/tmp/f"+str$(timer)+".dat"
tmp2$="/tmp/f"+str$(timer)+".gnu"
open "O",#1,tmp$
print #1,"# Kreditsumme Laufzeit/Jahren"
for j=1000 to 500000 step 1000
t=@laufzeit(j)
print #1,j;" ";t/12
print j;" EURO --> ";int(t/12);" Jahre";
if (t mod 12)
print " und ";(t mod 12);" Monate."
else
print "."
endif
exit if t=0
next j
close #1
open "O",#1,tmp2$
print #1,"set grid"
print #1,"set xlabel 'Kreditsumme'"
print #1,"set ylabel 'Laufzeit / Jahre'"
print #1,"plot [][:30] "+chr$(34)+tmp$+chr$(34)+" u 1:2 w st t 'mon. Belastung: "+str$(belastung)+"+"+str$(extratilgung)+"'"
print #1,"pause -1"
close #1
system "gnuplot "+tmp2$
system "rm -f "+tmp$
system "rm -f "+tmp2$
quit
function laufzeit(gesamt)
local i
i=0
do
zins=gesamt*zinssatz/12
exit if 12*zins>12*belastung+extratilgung
' print i,int(i/12),gesamt,zins,(belastung-zins)
sub gesamt,(belastung-zins)
inc i
exit if gesamt<1000
if (i mod 12)=0
sub gesamt,extratilgung
endif
loop
return i
endfunction
......@@ -7,4 +7,5 @@
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
15582 2012-05-07 <a href="Whets.bas">Whets.bas</a> Whetstone (benchmark)
</pre></body></html>
a$="26.11.2010"
i=1
while param$(i)<>""
a$=param$(i)
inc i
wend
if julian(a$)<0
print "Usage: xbasic kw.bas dd.mm.yyyy"
quit
endif
print a$,
print @kw(a$)
quit
' Gibt Kalenderwoche zu Datum (c) Markus Hoffmann
function kw(d$)
local j,j2,wt,wt2,a,b
j=julian(d$)
wt=(j+7) mod 7