Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Pixelrennen...
| Uploader: |  OneCypher |
| Datum/Zeit: | 03.09.2008 16:14:00 |
'Copyright by Christian H. alias OneCypher
'Diesen Quelltext stelle ich ausschließlich für nichtkommerzielle Zwecke zur Verfügung!
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
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) > 10 + dist then 'Solange Ziel(+Tolleranz) nicht erreicht dann...
tx = int((rnd *3) -1) '... Schauen wir mal wo man so hintreten kann
ty = int((rnd *3) -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..
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 'Da man wieder frei laufen kann, Distanzerweiterung auf 0 setzen
else
dist = dist +1 'Da blockiert was den Weg, also Distanzerweiterung erhöhen!
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 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 /4)
fstat->y = int(sy /4)
pset(fstat->x,fstat->y),RGB(255,0,0)
fstat->nx_st = fstat
lstat = fstat
apx = new px
spx = apx
for i = 1 to 5000
'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 < 5000 then apx = apx->nx_px else apx->nx_px = spx
next
apx = spx
do
in = inkey
getmouse mx,my,,bt
apx->work
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
loop until in = "q"