fb:porticula NoPaste

Info / Hilfe Liste
Übersicht / Liste Neu
Datei hochladen Suche
Quellcode suchen
Dateidownload
Spiel des Lebens (Console) :-)

Uploader:	derDachs
Datum/Zeit:	06.03.2012 11:47:40
'Game of Life

'------------

'eine Zelle hat 8 Nachbarn

'eine tote Zelle mit 3 Lebenden Nachbarn, wird in der nächsten Generation neugeboren

'Lebende mit weniger als 2 Nachbarn, sterben in der nächsten an Einsamkeit

'Lebende mit 2 oder 3, beleiben in der nächsten Gen lebend

'Zellen mit mehr als 3 Nachbarn, sterben



'dies ist ein EndlosFeld, Nachbarn die nicht im sichtbaren Bereich liegen, sind

'jene welche auf der gegenüberliegenden Seite sind.

'linker Nachbar von Zelle(0,0) ist (19,0) bei Feldgrösse 20





'Author: Dennis Briese





Declare Sub welt_initialisieren(ByRef pGen As Byte Ptr)

Declare Sub zeichne_welt(ByRef pGen As Byte Ptr)

Declare Sub naechsteGen(ByRef pAktGen As Byte Ptr, ByRef pNeuGen As Byte Ptr)

Declare Function anzNachbarn(ByRef pGen As Byte Ptr, Index As Integer) As Integer







#Define SPEED 10

#Define FELDWEITE 20



Const As Integer ANZZELLEN = FELDWEITE^2



Dim taste   As String

Dim pAktGen As Byte Ptr

Dim pNeuGen As Byte Ptr



pAktGen = Callocate(ANZZELLEN-1,Len(Byte))

pNeuGen = Callocate(ANZZELLEN-1,Len(Byte))



'***************************Main - Prog********************************

    Color 3,15

    Cls



    welt_initialisieren(pAktGen)

    Print "Escape fuer Ende, Enter fuer Neustart"



    Color 15,3



    Do



        taste = InKey



        Sleep 100 \ SPEED



        zeichne_welt(pAktGen)

        naechsteGen(pAktGen,pNeuGen)



        Swap pAktGen,pNeuGen



        If taste = Chr(13) Then welt_initialisieren(pAktGen)





    Loop Until taste = Chr(27)



    End



'**********************************************************************



'funktionen



Sub welt_initialisieren(ByRef pGen As Byte Ptr)

    Dim i As Integer = 0

    Dim r As Integer

    Randomize Timer

    Do Until i = ANZZELLEN

        r=Int(Rnd*100)+1

        pGen[i]=IIf(r<50,0,1)

        i=i+1

    Loop

End Sub



Sub zeichne_welt(ByRef pGen As Byte Ptr)

    Dim i As Integer = 0

    Dim As Integer x,y

    Do Until i = ANZZELLEN

        x = i Mod FELDWEITE

        y = i \ FELDWEITE

        Locate(y+3,x+3)

        Print *IIf(pGen[i]=1,@"*",@" ")

        i+=1

    Loop

End Sub



Sub naechsteGen(ByRef pAktGen As Byte Ptr, ByRef pNeuGen As Byte Ptr)

    Dim i As Integer = 0

    Dim As Integer x,y,nb,akt

    Do Until i = ANZZELLEN



        nb = anzNachbarn(pAktGen,i)

        akt = pAktGen[i]



        pNeuGen[i]=akt



        If (akt=0) And (nb=3) Then pNeuGen[i]=1

        If (akt=1) And (nb<2) Then pNeuGen[i]=0

        If (akt=1) And (nb>3) Then pNeuGen[i]=0



        i=i+1

    Loop

End Sub



Function anzNachbarn(ByRef pGen As Byte Ptr,Index As Integer) As Integer

    Dim As Integer x,y,lx,rx,oy,uy,nb



    x = index Mod FELDWEITE

    y = index \ FELDWEITE



    lx =  x-1

    rx = (x+1) Mod FELDWEITE

    oy =  y-1

    uy = (y+1) Mod FELDWEITE



    If lx < 0 Then lx = FELDWEITE-1

    If oy < 0 Then oy = FELDWEITE-1





    nb = pGen[ y * FELDWEITE + lx] + pGen[ y * FELDWEITE + rx] 'Nachbar links und rechts

    nb+= pGen[oy * FELDWEITE +  x] + pGen[uy * FELDWEITE +  x] 'Nachbar oben und unten

    nb+= pGen[oy * FELDWEITE + lx] + pGen[uy * FELDWEITE + lx] 'links oben, links unten

    nb+= pGen[oy * FELDWEITE + rx] + pGen[uy * FELDWEITE + rx] 'rechts oben, rechts unten



    Return nb

End Function