Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
vektortrainer_1_2_1.bas
| Uploader: |  XelaS |
| Datum/Zeit: | 26.02.2011 19:21:48 |
Hinweis: Dieser Quelltext ist Bestandteil des Projekts Vektortrainer, zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
'Zum Senden der Performancestatistik wird Code von PMedia verwendet
'Code: Websites selbst verarbeiten
'Urheber: PMedia, GPL-Lizenz
#Define WIN_INCLUDEALL
#ifdef __FB_WIN32__
#include once "win/winsock2.bi"
#else
#include once "crt/netdb.bi"
#include once "crt/sys/socket.bi"
#include once "crt/netinet/in.bi"
#include once "crt/arpa/inet.bi"
#include once "crt/unistd.bi"
#endif
#ifndef recvbufflen
#define RECVBUFFLEN 16384
#endif
#ifndef newline
#define newline chr(13,10)
#endif
Sub InitWinsock Constructor
#ifdef __FB_WIN32__
'' init winsock
Dim wsaData As WSAData
If( WSAStartup( MAKEWORD( 1, 1 ), @wsaData ) <> 0 ) Then
Print "Error: WSAStartup failed"
End 1
End If
#Endif
End Sub
Sub ExitWinsock Destructor
#ifdef __FB_WIN32__
WSACleanup
#Endif
End Sub
Function httppost(server As String, path As String, toPost As String, hadd as string = "") As String
Dim IP As Integer
Dim ia As in_addr
Dim s As SOCKET
Dim hostentry As hostent Ptr
Dim sendbuffer As String
Dim recvbuffer As Zstring * RECVBUFFLEN+1
Dim bytes As Integer
Dim sa As sockaddr_in
Dim in as string
ia.S_addr = inet_addr( server )
If ( ia.S_addr = INADDR_NONE ) Then
hostentry = gethostbyname( server )
If ( hostentry = 0 ) Then
return "IP couldn't be resolved!"
End If
IP = *cast( Integer Ptr, *hostentry->h_addr_list )
Else
IP = ia.S_addr
End If
s = opensocket( AF_INET, SOCK_STREAM, IPPROTO_TCP )
If( s = 0 ) Then
return "Socket couldn't be opened."
End If
sa.sin_port = htons( 80 )
sa.sin_family = AF_INET
sa.sin_addr.S_addr = ip
If ( connect( s, cast( PSOCKADDR, @sa ), Len( sa )) = SOCKET_ERROR ) Then
closesocket( s )
return "Couldn't connect to host"
End If
sendBuffer = "POST /" + path + " HTTP/1.0" + NEWLINE + _
"Host: " + server + NEWLINE + _
"Content-Type: application/x-www-form-urlencoded" + NEWLINE + _
"Content-Length: " + str(len(toPost)) + NEWLINE + _
"Connection: close" + NEWLINE + _
hadd + _
NEWLINE + _
toPost + NEWLINE
If( send( s, sendBuffer, Len( sendBuffer ), 0 ) = SOCKET_ERROR ) Then
closesocket( s )
return "Couldn't send request"
End If
Do
bytes = recv( s, recvBuffer, RECVBUFFLEN, 0 )
If( bytes <= 0 ) Then
exit do
End If
recvbuffer[bytes] = 0
in += recvbuffer
Loop
shutdown( s, 2 )
closesocket( s )
return in
End Function
'/Websites selbst verarbeiten by PMedia (www.freebasic-portal.de)
'Präprozessor-Definitionen für optische Menüeffekte
'maximale Helligkeitserhöhung in heller Schaltfläche
#DEFINE HIGHLIGHTINGMAX 40
'maximale Helligkeitserhöhung (zuzügl. Quadratzeugs) am hellen Schaltflächenrand
#DEFINE HIGHLIGHTINGEDGEMAX 40
'Breite des hellen Schaltflächenrandes (Pixel)
#DEFINE HIGHLIGHTINGEDGEBREITE 10
'Dämpfung der Quadratischen Helligkeitszunahme zum Rand der hellen Schaltfläche hin
#DEFINE HIGHLIGHTINGEDGEQUADRATDAEMPFUNG 1
'Schritte, in denen Helligkeitserhöhungen im Zeitintervall menusleep erfolgen
#DEFINE HIGHLIGHTINGSTEP 4
#DEFINE HIGHLIGHTINGEDGESTEP 4
'Analog dazu die Einstellungen für die Dunkle Schaltfläche
#DEFINE DARKLIGHTINGMAX 40
#DEFINE DARKLIGHTINGEDGEMAX 35
#DEFINE DARKLIGHTINGEDGEBREITE 15
#DEFINE DARKLIGHTINGEDGEQUADRATDAEMPFUNG 0.2
#DEFINE DARKLIGHTINGSTEP 4
#DEFINE DARKLIGHTINGEDGESTEP 4
declare function schaltflaeche (mx as integer, my as integer, x1 as integer, y1 as integer, x2 as integer, y2 as integer, text as string) as integer
declare sub zschaltflaeche (x1 as integer, y1 as integer, x2 as integer, y2 as integer, text as string)
declare function ppmload (filename as string) as integer
declare sub ppmdisplay ()
declare sub ueberschrift (y as integer,text as string)
#include "file.bi"
declare sub cop()
dim as integer x(11),y(11),z(11),i, xerg, yerg, zerg, xein, yein, zein, paramin, paramax, anzahl, mesg,i2
dim as integer bildschirmbreite, bildschirmhoehe
dim as byte plusmin(11),mult,verbosemode
dim as string strin
dim shared as uinteger bordercl,lttcl1
bordercl=rgb(237,204,18)
lttcl1=rgb(0,255,255)
dim shared as integer menusleep,ch,f,g
menusleep=5
'Deklareaktionen fürs Bild
dim shared as ubyte colors(1 to 1024,1 to 768,3)
dim shared as integer picbreite,pichoehe,ppmthere
'globales fuer Schaltflaechenanimation
dim shared as ubyte highlighting, highlightingedge
'Bildlade- und Bildanzeigzeitmessung
dim shared as double timer1,timer2,timer3
'Zufallszeug
dim shared as double rndvar
dim as integer rndvar2
'Statistiken ja/nein
dim shared as byte pstat,ersterstart
ersterstart=0
'Statistiken senden
dim shared as string sstrin, sendstrin
'Funktion zum Einlesen des PPM-Bildes in Array
function ppmload (filename as string) as integer
print
'Deklarationen für das Hintergrundbild
dim as integer byt,y,x,i
dim as ubyte testbyte,testbyte2,count, puffer(3072)
dim as string pictest
'Beim Einlesen werden binäre Bilddaten vorausgesetzt
if FILEEXISTS(filename) then
f=freefile
open filename for input as #f
input #f, pictest
input #f, pictest
'Wenn sich in der Datei ein Kommentar befindet (von # eingeleitet),
'wird eine Linie übersprungen
If mid(pictest,1,1)="#" then
input #f, pictest
end if
picbreite=valint(pictest)
'Das Hintergrundbild hat nunmal eine Breite von 1024 Pixeln
if picbreite<>1024 then
color 15,0
cls
print "Unpassendes Hintergrundbild."
print "Das Programm wird beendet."
sleep 2000,1
sleep 2000
end
end if
pichoehe= valint(mid(pictest,instr(pictest," ")))
input #f, pictest
close #f
'Nachdem im Input-Modus die Bildhoehe und -breite erfasst wurden, wird der Anfang der Binaerdaten festgestellt
f=freefile
open filename for binary as #f
y=0
do
y=y+1
get #f,y,testbyte
get #f,y+1,testbyte2
'falls das newline-Zeichen (10) gefunden wurde und sich danach kein Kommentar
'befindet (Raute, 35) wird dies registriert, nach 3 richtigen Zeilen, beginnen die
'Bilddaten
If testbyte=10 and testbyte2<>35 then count=count+1
If count=3 then exit do
loop until count=3
byt=y+1
'byt... Nummer des 1. Bytes mit RGB-Farbinformationen
y=0
'die Bilddaten werden eingelesen
locate 15
for y=1 to pichoehe
' print "x=";x
x=1
'das Puffer-Array fasst die Bilddaten einer Zeile
get #f,(x-1)*3+byt+(y-1)*picbreite*3,puffer()
'Die einzelnen RGB-Werte werden dem Puffer entnommen
for i=0 to 1023
colors(x+i,y,0)=puffer(0+i*3)
colors(x+i,y,1)=puffer(1+i*3)
colors(x+i,y,2)=puffer(2+i*3)
next
' get #f,x*3+13+(y-1)*breite*3,red,1
' get #f,x*3+14+(y-1)*breite*3,green,1
'get #f,x*3+15+(y-1)*breite*3,blue,1
next
close #f
return 1
else
'Falls kein Bild existieren sollte, wird alles auf Weiß gesetzt
for y=1 to 768
for x=1 to 1024
colors(x,y,0)=255
colors(x,y,1)=255
colors(x,y,2)=255
next
next
return 0
end if
end function
'zschaltflaeche zeichnet die Umrisse der Schaltflaeche mit Text
sub zschaltflaeche (x1 as integer, y1 as integer, x2 as integer, y2 as integer, text as string)
dim as integer startx, starty
starty=(y1+y2)/2
startx=(x2-x1-len(text)*8)/2+x1
line (x1,y1)-(x2,y2),bordercl,B
draw string (startx,starty),text,lttcl1
end sub
'gibt Überschrift mittig bei festgelegter y-Koordinate aus
sub ueberschrift (y as integer,text as string)
dim startx as integer
startx=(1024-len(text)*8)/2
draw string (startx, y),text,lttcl1
end sub
'Generiert animierte Schaltflaeche, die bei Mouseover hell wird
'Rückgabewerte: 1 (falls angeklickt), sonst 0
function schaltflaeche (mx as integer, my as integer, x1 as integer, y1 as integer, x2 as integer, y2 as integer, text as string) as integer
dim as integer f,g,x,y
dim as integer startx, starty
dim as integer dred,dgreen,dblue
starty=(y1+y2)/2
startx=(x2-x1-len(text)*8)/2+x1
'Feststellungen, ob Maus innerhalb des Schaltflaechenbereichs
If mx>x1 and mx<x2 then
If my>y1 and my<y2 then
f=mx
g=my
do
if highlighting<HIGHLIGHTINGMAX then
highlighting=highlighting+HIGHLIGHTINGSTEP
for f=x1 to x2
for g=y1 to y2
dred=colors(f,g,0)+highlighting
if dred>255 then dred=255
dgreen=colors(f,g,1)+highlighting
if dgreen>255 then dgreen=255
dblue=colors(f,g,2)+highlighting
if dblue>255 then dblue=255
pset(f,g),RGB(dred,dgreen,dblue)
next
next
end if
draw string (startx,starty),text,lttcl1
if highlightingedge<HIGHLIGHTINGEDGEMAX then
highlightingedge=highlightingedge+HIGHLIGHTINGEDGESTEP
for f=x1 to x2
for g=y1-HIGHLIGHTINGEDGEBREITE to y1
dred=colors(f,g,0)+highlightingedge+(y1-g)^2*HIGHLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/HIGHLIGHTINGEDGEMAX)
if dred>255 then dred=255
dgreen=colors(f,g,1)+highlightingedge+(y1-g)^2*HIGHLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/HIGHLIGHTINGEDGEMAX)
if dgreen>255 then dgreen=255
dblue=colors(f,g,2)+highlightingedge+(y1-g)^2*HIGHLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/HIGHLIGHTINGEDGEMAX)
if dblue>255 then dblue=255
pset(f,g),RGB(dred,dgreen,dblue)
next
for g=y2 to y2+HIGHLIGHTINGEDGEBREITE
dred=colors(f,g,0)+highlightingedge+(g-y2)^2*HIGHLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/HIGHLIGHTINGEDGEMAX)
if dred>255 then dred=255
dgreen=colors(f,g,1)+highlightingedge+(g-y2)^2*HIGHLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/HIGHLIGHTINGEDGEMAX)
if dgreen>255 then dgreen=255
dblue=colors(f,g,2)+highlightingedge+(g-y2)^2*HIGHLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/HIGHLIGHTINGEDGEMAX)
if dblue>255 then dblue=255
pset(f,g),RGB(dred,dgreen,dblue)
next
next
for g=y1-HIGHLIGHTINGEDGEBREITE to y2+HIGHLIGHTINGEDGEBREITE
for f=x1-HIGHLIGHTINGEDGEBREITE to x1
dred=colors(f,g,0)+highlightingedge+((x1-f))^2*HIGHLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/HIGHLIGHTINGEDGEMAX)
if dred>255 then dred=255
dgreen=colors(f,g,1)+highlightingedge+(x1-f)^2*HIGHLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/HIGHLIGHTINGEDGEMAX)
if dgreen>255 then dgreen=255
dblue=colors(f,g,2)+highlightingedge+(x1-f)^2*HIGHLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/HIGHLIGHTINGEDGEMAX)
if dblue>255 then dblue=255
pset(f,g),RGB(dred,dgreen,dblue)
next
for f=x2 to x2+HIGHLIGHTINGEDGEBREITE
dred=colors(f,g,0)+highlightingedge+(f-x2)^2*HIGHLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/HIGHLIGHTINGEDGEMAX)
if dred>255 then dred=255
dgreen=colors(f,g,1)+highlightingedge+(f-x2)^2*HIGHLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/HIGHLIGHTINGEDGEMAX)
if dgreen>255 then dgreen=255
dblue=colors(f,g,2)+highlightingedge+(f-x2)^2*HIGHLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/HIGHLIGHTINGEDGEMAX)
if dblue>255 then dblue=255
pset(f,g),RGB(dred,dgreen,dblue)
next
next
end if
getmouse f,g,x,y
If f<x1 or f>x2 or g<y1 or g>y2 then
line (x1,y1)-(x2,y2),bordercl,B
for f=x1-HIGHLIGHTINGEDGEBREITE to x2+HIGHLIGHTINGEDGEBREITE
for g=y1-HIGHLIGHTINGEDGEBREITE to y2+HIGHLIGHTINGEDGEBREITE
pset(f,g),RGB(colors(f,g,0),colors(f,g,1),colors(f,g,2))
next
next
line (x1,y1)-(x2,y2),bordercl,B
draw string (startx,starty),text,lttcl1
highlighting=0
highlightingedge=0
exit do
end if
If y=1 then
exit do
end if
sleep menusleep,1
loop
if y=1 then
return 1
else
return 0
end if
end if
end if
end function
'Analog zu schaltflaeche, doch Animation ins Dunkle
function dkschaltflaeche (mx as integer, my as integer, x1 as integer, y1 as integer, x2 as integer, y2 as integer, text as string) as integer
dim as integer f,g,x,y
dim as integer startx, starty
dim as integer dred,dgreen,dblue
starty=(y1+y2)/2
startx=(x2-x1-len(text)*8)/2+x1
If mx>x1 and mx<x2 then
If my>y1 and my<y2 then
f=mx
g=my
do
if highlighting<DARKLIGHTINGMAX then
highlighting=highlighting+DARKLIGHTINGSTEP
for f=x1 to x2
for g=y1 to y2
dred=colors(f,g,0)-highlighting
if dred<0 then dred=0
dgreen=colors(f,g,1)-highlighting
if dgreen<0 then dgreen=0
dblue=colors(f,g,2)-highlighting
if dblue<0 then dblue=0
pset(f,g),RGB(dred,dgreen,dblue)
next
next
end if
draw string (startx,starty),text,lttcl1
if highlightingedge<DARKLIGHTINGEDGEMAX then
highlightingedge=highlightingedge+DARKLIGHTINGEDGESTEP
for f=x1 to x2
for g=y1-DARKLIGHTINGEDGEBREITE to y1
dred=colors(f,g,0)-highlightingedge-(y1-g)^2*DARKLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/DARKLIGHTINGEDGEMAX)
if dred<0 then dred=0
dgreen=colors(f,g,1)-highlightingedge-(y1-g)^2*DARKLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/DARKLIGHTINGEDGEMAX)
if dgreen<0 then dgreen=0
dblue=colors(f,g,2)-highlightingedge-(y1-g)^2*DARKLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/DARKLIGHTINGEDGEMAX)
if dblue<0 then dblue=0
pset(f,g),RGB(dred,dgreen,dblue)
next
for g=y2 to y2+DARKLIGHTINGEDGEBREITE
dred=colors(f,g,0)-highlightingedge-(g-y2)^2*DARKLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/DARKLIGHTINGEDGEMAX)
if dred<0 then dred=0
dgreen=colors(f,g,1)-highlightingedge-(g-y2)^2*DARKLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/DARKLIGHTINGEDGEMAX)
if dgreen<0 then dgreen=0
dblue=colors(f,g,2)-highlightingedge-(g-y2)^2*DARKLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/DARKLIGHTINGEDGEMAX)
if dblue<0 then dblue=0
pset(f,g),RGB(dred,dgreen,dblue)
next
next
for g=y1-DARKLIGHTINGEDGEBREITE to y2+DARKLIGHTINGEDGEBREITE
for f=x1-DARKLIGHTINGEDGEBREITE to x1
dred=colors(f,g,0)-highlightingedge-((x1-f))^2*DARKLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/DARKLIGHTINGEDGEMAX)
if dred<0 then dred=0
dgreen=colors(f,g,1)-highlightingedge-(x1-f)^2*DARKLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/DARKLIGHTINGEDGEMAX)
if dgreen<0 then dgreen=0
dblue=colors(f,g,2)-highlightingedge-(x1-f)^2*DARKLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/DARKLIGHTINGEDGEMAX)
if dblue<0 then dblue=0
pset(f,g),RGB(dred,dgreen,dblue)
next
for f=x2 to x2+DARKLIGHTINGEDGEBREITE
dred=colors(f,g,0)-highlightingedge-(f-x2)^2*DARKLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/DARKLIGHTINGEDGEMAX)
if dred<0 then dred=0
dgreen=colors(f,g,1)-highlightingedge-(f-x2)^2*DARKLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/DARKLIGHTINGEDGEMAX)
if dgreen<0 then dgreen=0
dblue=colors(f,g,2)-highlightingedge-(f-x2)^2*DARKLIGHTINGEDGEQUADRATDAEMPFUNG*(highlightingedge/DARKLIGHTINGEDGEMAX)
if dblue<0 then dblue=0
pset(f,g),RGB(dred,dgreen,dblue)
next
next
end if
getmouse f,g,x,y
If f<x1 or f>x2 or g<y1 or g>y2 then
line (x1,y1)-(x2,y2),bordercl,B
for f=x1-DARKLIGHTINGEDGEBREITE to x2+DARKLIGHTINGEDGEBREITE
for g=y1-DARKLIGHTINGEDGEBREITE to y2+DARKLIGHTINGEDGEBREITE
pset(f,g),RGB(colors(f,g,0),colors(f,g,1),colors(f,g,2))
next
next
line (x1,y1)-(x2,y2),bordercl,B
draw string (startx,starty),text,lttcl1
highlighting=0
highlightingedge=0
exit do
end if
If y=1 then
exit do
end if
sleep menusleep,1
loop
if y=1 then
return 1
else
return 0
end if
end if
end if
end function
'Zeigt eingelesenes PPM-Bild an
sub ppmdisplay()
dim as integer x,y
for y=1 to pichoehe
for x=1 to picbreite
pset(x-1,y-1),RGB(colors(x,y,0),colors(x,y,1),colors(x,y,2))
next
if frac(y/40)=1 then sleep 40
next
end sub
'Modus mit Ausgabe der Messwerte
if inkey="v" then verbosemode=1
timer3=timer
screeninfo bildschirmbreite, bildschirmhoehe,,,,,
'bei 1024*768 wird Vollbild aktiviert, sonst im Fenster
'Farbtiefe 32 bit
If bildschirmbreite=1024 and bildschirmhoehe=768 then
screen 20,32,,&H01
elseIf bildschirmbreite>=1024 and bildschirmhoehe>=768 then
screen 20,32
elseIf bildschirmbreite<1024 or bildschirmhoehe<768 then
Print "Ihre Bildschirmaufloesung ist zu niedrig"
Print "Fuer diese Programm werden 1024 x 768 benoetigt."
Print
Print "Druecken Sie eine Taste, um das Programm zu beenden."
sleep
end
end if
If FILEEXISTS("ppm1.ppm")=0 then
Print "Bitte entpacken Sie das .zip-Archiv."
Print
Print "Das geht so: Rechtsklick auf den Ordner vektortrainer___.zip -> 'Alle extrahieren', den Anweisungen folgen. Dann die entpackten Dateien verwenden."
Print
Print "Eine ausfuehrliche Anleitung finden Sie auf xdd0prog.wordpress.com"
print
print "Druecken Sie eine Taste, um das Programm zu beenden."
Print
sleep 60000
end
end if
if FILEEXISTS("vektortrainer_1_2wsettings.txt")=0 then
ersterstart=1
ppmthere=ppmload("ppm1.ppm")
if ppmthere<>0 then
ppmdisplay
else
color lttcl1,rgb(255,255,255)
cls
end if
ueberschrift (50,"Moechten Sie dem Programm das Senden anonyme Performancestatistiken erlauben, um die Programmentwicklung zu unterstuetzen?")
zschaltflaeche (100,100,900,200,"Ja. (Es wird eine Internetverbindung benoetigt)")
zschaltflaeche (100,250,900,350,"Nein.")
pstat=0
do
highlighting=0
getmouse f,g
if dkschaltflaeche (f,g,100,100,900,200,"Ja. (Es wird eine Internetverbindung benoetigt)") then
pstat=1
f=freefile
open ("vektortrainer_1_2wsettings.txt") for output as #f
randomize -timer*3
for i=0 to 4
rndvar=rnd*18145
randomize rndvar*timer
rndvar2=fix(rnd*25)
sleep rndvar2
next
rndvar=rnd*999999999999
print #f, str(rndvar)
close #f
elseif dkschaltflaeche (f,g,100,250,900,350,"Nein") then
pstat=0
ch=2
f=freefile
open ("vektortrainer_1_2wsettings.txt") for output as #f
print #f, "0"
close #f
end if
sleep menusleep
if inkey=chr(27) then end
loop until ch<>0 or pstat<>0
else
f=freefile
open ("vektortrainer_1_2wsettings.txt") for input as #f
input #f, rndvar
close #f
if rndvar=0 then
pstat=0
else
pstat=1
end if
end if
timer1=timer
ppmthere=ppmload("ppm1.ppm")
timer1=timer-timer1
do
if ppmthere<>0 then
timer2=timer
ppmdisplay
timer2=timer-timer2
else
color lttcl1,rgb(255,255,255)
cls
end if
ch=0
timer3=timer-timer3
if verbosemode=1 then
ueberschrift (10,"Bildladezeit:"+str(timer1))
ueberschrift (30,"Bildanzeigezeit:"+str(timer2)+"--- gesamte Programmstartzeit:"+str(timer3))
end if
ueberschrift (50,"Herzlich Willkommen zum Uebungsprogramm fuer die Rechnung mit Spaltenvektoren!")
zschaltflaeche (100,100,900,200,"Vektorenaddition, -subtraktion und -multiplikation")
zschaltflaeche (100,250,900,350,"Kreuzprodukt von Vektoren")
zschaltflaeche (100,400,900,500,"Skalarprodukt von Vektoren")
zschaltflaeche (100,550,900,650,"Programm beenden")
do
highlighting=0
getmouse f,g
if dkschaltflaeche (f,g,100,100,900,200,"Vektorenaddition, -subtraktion und -multiplikation") then
ch=1
elseif dkschaltflaeche (f,g,100,250,900,350,"Kreuzprodukt von Vektoren") then
ch=2
elseif dkschaltflaeche (f,g,100,400,900,500,"Skalarprodukt von Vektoren") then
ch=3
elseif dkschaltflaeche (f,g,100,550,900,650,"Programm beenden") then
ch=4
end if
sleep menusleep
if inkey=chr(27) then end
loop until ch<>0
if ppmthere<>0 then
ppmdisplay
else
color lttcl1,rgb(255,255,255)
cls
end if
select case ch
case 1
zschaltflaeche (100,100,900,200,"Multiplikation von Vektoren einbeziehen")
zschaltflaeche (100,300,900,400,"Keine Multiplikation von Vektoren")
do
ch=0
highlighting=0
getmouse f,g
if schaltflaeche (f,g,100,100,900,200,"Multiplikation von Vektoren einbeziehen") then
mult=1
ch=1
elseif schaltflaeche (f,g,100,300,900,400,"Keine Multiplikation von Vektoren") then
mult=0
ch=2
end if
if inkey=chr(27) then end
loop until ch<>0
if ppmthere<>0 then
ppmdisplay
else
color lttcl1,rgb(255,255,255)
cls
end if
locate 1,1
Print "Bitte machen Sie nun Angaben zu den gewuenschten Uebungsparametern"
Print "oder druecken Sie jeweils Enter, um die Standardwerte zu verwenden."
Print
do
Input "Bitte geben Sie die Anzahl der Vektoren ein. (Standard:5)", strin
If strin="" then
anzahl=5
else
anzahl=valint(strin)
If anzahl>8 or anzahl<2 then print "Die Anzahl muss zwischen 1 und 9 liegen"
end if
loop until anzahl<9 and anzahl>1
Input "Bitte geben Sie die kleinste moegliche Zahl als x,y oder z-Wert eines Vektors an (Standard: -15)", strin
If strin="" then
paramin=-15
else
paramin=valint(strin)
end if
do
Input "Bitte geben Sie die groesste moegliche Zahl als x,y oder z-Wert eines Vektors an (Standard: 15)", strin
If strin="" then
paramax=15
else
paramax=valint(strin)
If paramax<=paramin then print "Die Anzahl muss groesser als der angegebene Minimalwert sein."
end if
loop until paramax>paramin
do
if ppmthere<>0 then
ppmdisplay
else
color lttcl1,rgb(255,255,255)
cls
end if
locate 1,1
randomize timer*17
for i2=0 to 2
for i=0 to anzahl-1
If i2=0 then
x(i)=rnd*(paramax-paramin)+paramin
if mult=1 then
print using " /#####_\ ";x(i);
else
print using " /#####_\ ";x(i);
end if
elseif i2=1 then
plusmin(i)=rnd*6-3
y(i)=rnd*(paramax-paramin)+paramin
if mult=1 then
if plusmin(i)>=0 then
print using "_+##*";plusmin(i);
else
print using " ##*";plusmin(i);
end if
else
if plusmin(i)<0 then
plusmin(i)=-1
print "-";
else
plusmin(i)=1
print "+";
end if
end if
print using "|#####| ";y(i);
else
z(i)=rnd*(paramax-paramin)+paramin
If mult=1 then
print using " _\#####/ ";z(i);
else
print using " _\#####/ ";z(i);
end if
end if
next
Print ""
next
xerg=0
yerg=0
zerg=0
Print "Ihre Loesung:"
Input "x ", strin
If strin="ENDE" or strin="ENDE" or strin="EXIT" or strin="EXIT" then
cop
else
xein=valint(strin)
end if
Input "y ", strin
If strin="ENDE" or strin="ENDE" or strin="EXIT" or strin="EXIT" then
cop
else
yein=valint(strin)
end if
Input "z ", strin
If strin="ENDE" or strin="ENDE" or strin="EXIT" or strin="EXIT" then
cop
else
zein=valint(strin)
end if
for i=0 to anzahl-1
xerg=xerg+x(i)*plusmin(i)
yerg=yerg+y(i)*plusmin(i)
zerg=zerg+z(i)*plusmin(i)
next
If xein=xerg and yein=yerg and zein=zerg then
Print "Richtig."
else
Print "Leider Falsch. Die Loesung ist:"
print using " /#####_\ ";xerg
print using " |#####| ";yerg
print using " _\#####/ ";zerg
end if
ch=0
zschaltflaeche (100,300,900,400,"Weitere Aufgabe bearbeiten")
zschaltflaeche (100,500,900,600,"Uebung beenden -> zum Hautpmenue")
do
highlighting=0
getmouse f,g
if schaltflaeche (f,g,100,300,900,400,"Weitere Aufgabe bearbeiten") then
ch=2
elseif schaltflaeche (f,g,100,500,900,600,"Uebung beenden -> zum Hautpmenue") then
ch=3
end if
sleep menusleep
if inkey=chr(27) then end
loop until ch<>0
loop until ch=3
case 2
locate 1,1
Print "Bitte machen Sie nun Angaben zu den gewuenschten Uebungsparametern"
Print "oder druecken Sie jeweils Enter, um die Standardwerte zu verwenden."
Print
Input "Bitte geben Sie die kleinste moegliche Zahl als x,y oder z-Wert eines Vektors an (Standard: -10)", strin
If strin="" then
paramin=-10
else
paramin=valint(strin)
end if
do
Input "Bitte geben Sie die groesste moegliche Zahl als x,y oder z-Wert eines Vektors an (Standard: 10)", strin
If strin="" then
paramax=10
else
paramax=valint(strin)
If paramax<=paramin then print "Die Anzahl muss groesser als der angegebene Minimalwert sein."
end if
loop until paramax>paramin
do
if ppmthere<>0 then
ppmdisplay
else
color lttcl1,rgb(255,255,255)
cls
end if
locate 1,1
randomize timer*17
for i2=0 to 2
for i=0 to 1
If i2=0 then
x(i)=rnd*(paramax-paramin)+paramin
print using " /#####_\ ";x(i);
elseif i2=1 then
plusmin(i)=rnd*6-3
y(i)=rnd*(paramax-paramin)+paramin
if i=0 then
print using " |#####| ";y(i);
else
print "X";
print using " |#####| ";y(i);
end if
else
z(i)=rnd*(paramax-paramin)+paramin
print using " _\#####/ ";z(i);
end if
next
Print ""
next
xerg=0
yerg=0
zerg=0
Print "Ihre Loesung:"
Input "x ", strin
If strin="ENDE" or strin="ENDE" or strin="EXIT" or strin="EXIT" then
cop
else
xein=valint(strin)
end if
Input "y ", strin
If strin="ENDE" or strin="ENDE" or strin="EXIT" or strin="EXIT" then
cop
else
yein=valint(strin)
end if
Input "z ", strin
If strin="ENDE" or strin="ENDE" or strin="EXIT" or strin="EXIT" then
cop
else
zein=valint(strin)
end if
xerg=y(0)*z(1)-z(0)*y(1)
yerg=z(0)*x(1)-z(1)*x(0)
zerg=x(0)*y(1)-y(0)*x(1)
If xein=xerg and yein=yerg and zein=zerg then
Print "Richtig."
else
Print
Print "Leider Falsch. Die Loesung ist:"
print using " /#####_\ ";xerg
print using " |#####| ";yerg
print using " _\#####/ ";zerg
end if
ch=0
zschaltflaeche (100,300,900,400,"Weitere Aufgabe bearbeiten")
zschaltflaeche (100,500,900,600,"Uebung beenden -> zum Hautpmenue")
do
highlighting=0
getmouse f,g
if schaltflaeche (f,g,100,300,900,400,"Weitere Aufgabe bearbeiten") then
ch=2
elseif schaltflaeche (f,g,100,500,900,600,"Uebung beenden -> zum Hautpmenue") then
ch=3
end if
sleep menusleep
if inkey=chr(27) then end
loop until ch<>0
loop until ch=3
case 3
locate 1,1
Print "Bitte machen Sie nun Angaben zu den gewuenschten Uebungsparametern"
Print "oder druecken Sie jeweils Enter, um die Standardwerte zu verwenden."
Print
Input "Bitte geben Sie die kleinste moegliche Zahl als x,y oder z-Wert eines Vektors an (Standard: -8)", strin
If strin="" then
paramin=-8
else
paramin=valint(strin)
end if
do
Input "Bitte geben Sie die groesste moegliche Zahl als x,y oder z-Wert eines Vektors an (Standard: 8)", strin
If strin="" then
paramax=8
else
paramax=valint(strin)
If paramax<=paramin then print "Die Anzahl muss groesser als der angegebene Minimalwert sein."
end if
loop until paramax>paramin
do
if ppmthere<>0 then
ppmdisplay
else
color lttcl1,rgb(255,255,255)
cls
end if
locate 1,1
randomize timer*17
for i2=0 to 2
for i=0 to 1
If i2=0 then
x(i)=rnd*(paramax-paramin)+paramin
print using " /#####_\ ";x(i);
elseif i2=1 then
plusmin(i)=rnd*6-3
y(i)=rnd*(paramax-paramin)+paramin
if i=0 then
print using " |#####| ";y(i);
else
print "o";
print using " |#####| ";y(i);
end if
else
z(i)=rnd*(paramax-paramin)+paramin
print using " _\#####/ ";z(i);
end if
next
Print ""
next
xerg=0
yerg=0
zerg=0
Input "Ihre Loesung:", strin
If strin="ENDE" or strin="ENDE" or strin="EXIT" or strin="EXIT" then
cop
else
xein=valint(strin)
end if
xerg=x(0)*x(1)+y(0)*y(1)+z(0)*z(1)
If xein=xerg then
Print "Richtig."
else
Print
Print "Leider Falsch. Die Loesung ist: ";
print xerg
end if
ch=0
zschaltflaeche (100,300,900,400,"Weitere Aufgabe bearbeiten")
zschaltflaeche (100,500,900,600,"Uebung beenden -> zum Hautpmenue")
do
highlighting=0
getmouse f,g
if schaltflaeche (f,g,100,300,900,400,"Weitere Aufgabe bearbeiten") then
ch=2
elseif schaltflaeche (f,g,100,500,900,600,"Uebung beenden -> zum Hautpmenue") then
ch=3
end if
sleep menusleep
if inkey=chr(27) then end
loop until ch<>0
loop until ch=3
end select
loop until ch=4
sleep 100,1
cop
sub cop ()
screen 0
color 15,0
cls
if pstat=1 then
Print "Sende Performancestatistik..."
sendstrin=""
sendstrin="version=vektortrainer1.2&number="+str(rndvar)+"&ersterstart="+str(ersterstart)+"&werte="+str(timer1)+";"+str(timer2)+";"+str(timer3)
sstrin=httpPost("mitglied.multimania.de","/xdd/public/vektorstat/index.php",sendstrin)
if instr(sstrin,"hallo welt")<>0 then
print "Performancestatistik erfolgreich gesendet."
Print "Vielen Dank fuer Ihre Unterstuetzung der Weiterentwicklung."
else
Print "Senden fehlgeschlagen."
Print "Vielen Dank fuer die Programmbenutzung."
end if
else
Print "Vielen Dank fuer die Programmbenutzung."
end if
if inkey=chr(27) then end
Print
color 11
Print "Diese Anwendung steht unter der Lizenz 'GNU General Public License v3.0'"
color 15
Print "Programmiert in FreeBASIC (www.freebasic-portal.de)"
Print
Print "Verwendete HTTPPOST Implementierung: PMedia (www.freebasic-portal.de)"
Print "Lizenz: GNU General Public License v2.0"
Print
Print "Verwendetes Hintergrundbild: paul (dex), veroeffentlicht auf Flickr.com"
Print "Lizenz: Creativecommons BY 2.0"
Print
if inkey=chr(27) then end
Print "Sonstige Programme und evtl. neue Versionen dieses Programms finden Sie unter"
Print "xdd0prog.wordpress.com"
Print
if inkey=chr(27) then end
sleep 550,1
locate 18
Print " 2/2011 by"
locate 18
if inkey=chr(27) then end
sleep 220,1
Print " 2/2011 by Xela S."
Print
Print
Print
Print
Print
Print
color 11
Print "Druecken Sie eine Taste, um das Programm zu beenden."
sleep 60000
end sub