Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Pixelrennen mit maus ^^
| Uploader: |  OneCypher |
| Datum/Zeit: | 03.09.2008 17:51:10 |
function getlength(x1 as double,y1 as double,x2 as double,y2 as double) as double
dim dx as double = x2 - x1
dim dy as double = y2 - y1
dim l as double = SQR(dx * dx + dy *dy)
return l
end function
function red(col AS UINTEGER) as ubyte
red = col SHR 16
END function
function green(col AS UINTEGER) as ubyte
green = col SHR 8
END function
function blue(col AS UINTEGER) as ubyte
blue = col
end function
type st 'Wegpunkt definition
x as integer
y as integer
nx_st as st ptr
end type
type px 'Pixel definition
x as double 'Position X
y as double 'Position Y
dest as st ptr 'Zielwegpunkt
dist as integer 'Distanzerweiterung zum Zielwegpunkt (für Stau minimierung)
nx_px as px ptr 'Nächster Pixel
bg as uinteger 'Pixelhintergrund
slp as ubyte
declare sub work() 'LAUFZEIT :-D
end type
sub px.work()
dim dx as double 'Ziel X
dim dy as double 'Ziel Y
dim tx as double 'Temp X
dim ty as double 'Temp Y
dx = dest->x 'Ziel einlesen
dy = dest->y
if getlength(x,y,dx,dy) > 2+ dist then 'Solange Ziel(+Tolleranz) nicht erreicht dann...
tx = (rnd *2) -1 '... Schauen wir mal wo man so hintreten kann
ty = (rnd *2) -1 'Einfach mal auf gut Glück
if getlength(x,y,dx,dy) > getlength(x+tx,y+ty,dx,dy) then 'Wenn wir näher treten und...
if green(point(x+tx,y+ty)) = 0 then 'der nächste Schritt nicht ins Grüne führt..
slp = 0
if blue(bg) < 255 then bg = rgb(0,0,blue(bg) +1) 'dann Hintergrund um 1 hervorheben...
pset(x,y),bg 'Hintergrund zeichnen
x +=tx 'Neue Koordinaten übernehmen
y +=ty
bg = point(x,y) 'Neuen Hintergrund übernehmen
pset(x,y),RGB(0,255,0) 'Grünen Pixel setzen
dist = 0
end if
else
if dist > 10 then
if slp < 255 then slp = slp +1
pset(x,y),RGB(0,255 - slp,0)
else
dist = dist +1
end if
end if
else
dest = dest->nx_st 'WegPunkt erreicht, nächster ist an der Reihe!
end if
end sub
dim sx as integer 'Bildschirmgrößen
dim sy as integer
dim mx as integer 'Mausinfos
dim my as integer
dim bt as integer
screen 18, 32
screeninfo sx, sy
cls
dim i as integer 'Zum iterieren von irgendwas....
dim in as string 'Für Tastratur-eingaben...
dim paused as ubyte
dim spx as px ptr 'Erster Pixel
dim apx as px ptr 'Aktueller Pixel
dim fstat as st ptr 'Erster Wegpunkt
dim lstat as st ptr 'Letzter Wegpunkt
fstat = new st
fstat->x = int(sx /8)
fstat->y = int(sy /2)
pset(fstat->x,fstat->y),RGB(255,0,0)
fstat->nx_st = fstat
lstat = fstat
apx = new px
spx = apx
for i = 1 to 1000
'Neue Pixel generieren
apx->x = int(rnd*sx-1) +1
apx->y = int(rnd*sy-1) +1
apx->bg = point(apx->x,apx->y)
apx->dest = fstat
apx->nx_px = new px
if i < 1000 then apx = apx->nx_px else apx->nx_px = spx
next
apx = spx
paused = 1
do
in = inkey
getmouse mx,my,,bt
if paused = 0 then apx->work
fstat->x = mx
fstat->y = my
apx=apx->nx_px
if bt <> 0 and mx > 0 and my > 0 then
'Ein neuer Wegpunkt
lstat->nx_st = new st
lstat = lstat->nx_st
lstat->x = mx
lstat->y = my
lstat->nx_st = fstat
pset(mx,my),RGB(255,0,0)
while bt > 0
'Überlauf verhindern
getmouse mx,my,,bt
wend
end if
if in = "c" then
'Löscht und baut den Bildschirm wieder auf.
cls
sleep 1000
apx = spx->nx_px
while apx <> spx
apx->bg = RGB(0,0,0)
pset(apx->x,apx->y),RGB(0,255,0)
apx = apx->nx_px
wend
end if
if in = "p" then
if paused = 0 then
sleep 500
paused = 1
else
sleep 500
paused = 0
end if
end if
if in = "l" then
sleep 500
lstat->nx_st = fstat->nx_st
delete fstat
fstat = lstat->nx_st
end if
loop until in = "q"