Efektit

Oletko tehnyt jotain, mistä muut voisivat hyötyä. Postita vinkit tänne.
User avatar
Valtzu
Active Member
Posts: 115
Joined: Sun Aug 26, 2007 2:40 pm
Location: Sauvo
Contact:

Re: Efektit

Post by Valtzu » Wed Mar 23, 2011 8:40 pm

Teinpä midinluku-systeemin, jota voi käyttää apuna esim. introissa/demoissa jne. Käyttää (normaalisti) Windowsin mukana tulevaa town.midiä.

Code: Select all

Const SW = 800
Const SH = 600

SCREEN SW, SH


Type NOTES
    Field note     As Byte    // mikä nuotti (0-127)
    Field velocity As Byte    // voimakkuus
    Field start    As Integer // aloitus
    Field length   As Integer // pituus
    Field channel  As Byte    // midi kanava (0-15)
    Field track    As Byte    // monesko raita
    Field trackPtr As Integer // osoitin TRACKS kokoelmaan
    Field lyrics   As String  // nuottiin liitetyt sanat
End Type

Type TRACKS
    Field id         As Byte
    Field name       As String
    Field instrument As String
    Field minNote    As Byte
    Field maxNote    As Byte
End Type

Type TEMPOEVENT
    Field ms           As Integer // eventin aika millisekunteina
    Field tics         As Integer // eventin aika
    Field fact         As Float   // funktion sisäiseen käyttöön
    Field bpm          As Integer // tempo yleisimmässä muodossa (beats per minute)
    Field nextEventPtr As Integer // seuraavan tempo eventin osoitin (0, jos viimeinen)
    Field nextEventMs  As Integer // seuraavan tempo eventin aloitusaika
End Type

Function getTrackPtr(id)
    For nT.TRACKS = Each TRACKS
        If nT\id = id Then Return ConvertToInteger(nT)
    Next nT
    Return 0
End Function


Dim file As String, sound As String
file = "C:\WINDOWS\media\town.mid"

If Len(file)=0 Then
    StartSearch
        count=0
        Repeat
            file2$=FindFile()
            If file2$="" Then Exit
            If Lower(Right(file2$,4))=".m"+"id" Then
                count+1
                file=file2
                If Rand(1024)>512 Then Exit
            EndIf
        Forever
    EndSearch
    If count = 0 Then
        Print "No midi files found in this directory (where exe is located)"
        WaitKey
        End
    EndIf
EndIf
sound = Left(file,Len(file)-4)+".mp3"
If Not FileExists(sound) Then sound = file


Text 0,0,"reading midi. please wait."
DrawScreen
midi=ReadMIDI(file)
Cls


curTrack = 0

nT.TRACKS = Last(TRACKS)
lastTrack = nT\id

MARGIN = SW/30
heightRatio# = 1.8

noteReleaseF# = 1.8
noteRelease# = 1.8 // seconds
title$="Track 1"
PlaySound sound,80
start = Timer()

bpmEvent.TEMPOEVENT = First(TEMPOEVENT)
If bpmEvent = NULL Then
    Print "no tempo event set"
    WaitKey
    End
EndIf

musicPlaying = False

Repeat
    
    If bpmEvent\nextEventPtr <> 0 And msOffset >= bpmEvent\nextEventMs Then
        bpmEvent = ConvertToType(bpmEvent\nextEventPtr)
    EndIf
    
    If (KeyHit(200) Or KeyHit(208)) Or curTrack = 0 Then 
        If curTrack = 0 Then curTrack + 1
        curTrack = Min(lastTrack, Max(1, curTrack - KeyHit(200) + KeyHit(208)))
        trackPtr = getTrackPtr(curTrack)
        If Not trackPtr = 0 Then
            nT.TRACKS = ConvertToType(trackPtr)
            title = nT\name
        Else
            title = "Track "+curTrack
        EndIf
        SetWindow title + " - arrows up/down t"+"o change track"
    EndIf
    msOffset = (Timer() - start)
    
    noteCount = 0
    For nN.NOTES = Each NOTES
        timeDiff = (msOffset-nN\start)
        l# = (60000.0/bpmevent\bpm)*2
        If nN\track = curTrack Then
            If timeDiff >= -l And timeDiff < nN\length Then
                nT.TRACKS = ConvertToType(nN\trackPtr)
                range = nT\maxNote-nT\minNote
                noteDiff = nN\note-nT\minNote
                m# = SW/20 // margin
                my#= SH/20 // margin-y
                w# = (SW-m*2)/range
                h# = w
                x# = m + ((SW-m*2-w)/range)*noteDiff+w/2
                If timeDiff < 0 Then
                    f# =(-timeDiff/l)
                    y# = my + f*(SH-my*2)
                    c  = 255 -  255.0*f
                    tail=10
                    For j=y+h To y+h+tail-1 Step 2
                        cm=Max(0,c-(c/(tail-1))*(j-(y+h)))
                        Color cm,cm,cm
                        Box x-w/2,j,w,2
                    Next j
                    Color c,c,c
                    Box x-w/2, y, w, h
                Else
                    f# = timeDiff/Float(nN\length)
                    y# = my
                    c  = 255 - 255.0*f
                    Color c/3,c/2,c
                    w=w*(1+f)
                    Box x-w/2, y, w, h
                EndIf
            EndIf
        EndIf
        If timeDiff > nN\length Then Delete nN Else noteCount + 1
    Next nN
    
    Color cbwhite
    Text 0,0,"current bpm: "+bpmEvent\bpm
    
    DrawScreen
Until noteCount = 0



Function ReadMIDI( strFile As String )
    If Not FileExists(strFile) Then Return False
    If FileSize(strFile) < 20 Then Return False
    Dim f As Integer
    f = OpenToRead( strFile )
    If ReadInt(f) <> $4D546864 Then Return Error(f, "Invalid file header!")
    
    Dim chunkSize As Integer, midiType As Short, trackCount As Short, timeDiv As Short
    chunkSize  = ReadInt2(f) // 6
    midiType = ReadShort2(f) // 0, 1, 2
    If midiType > 1 Then Error(f, "Feature missing! Can't handle this kind of midi (type "+midiType+") :(")
    trackCount = ReadShort2(f) // 1-65536
    timeDiv    = ReadShort2(f)
    
    
    Dim mem As Integer, memOffset As Integer, timeOffset As Integer
    memOffset=0
    mem = MakeMEMBlock(4)
    Dim a As Integer, deltaTime As Integer, start As Integer, eventType As Byte, tmpByte As Byte
    Dim sequenceNumber(1) As Byte, tmpInt As Integer, msgType As Byte, midiCh As Byte, tmpString As String
    For a = 0 To trackCount-1
        nT.TRACKS = New(TRACKS)
        nT\id     = a
        nT\maxNote= 0
        nT\minNote= 127
        trackPtr  = ConvertToInteger(nT)
        tmpInt=ReadInt(f)
        If tmpInt <> $4D54726B Then Error(f, "Invalid track header! ("+Hex(tmpInt)+")")
        chunkSize = ReadInt2(f)
        start = FileOffset(f)
        timeOffset=0
        lastTempoEventMs = 0
        lastTempoEvent   = 0
        trackVolume      = 127
        lyrics$          = ""
        TE.TEMPOEVENT = First(TEMPOEVENT)
        While FileOffset(f) < (start + chunkSize)
            deltaTime=ReadVarLen(f)
            if deltaTime>0 then lyrics = ""
            timeOffset=timeOffset+deltaTime
            If TE = NULL Then
                msOffset = 0
            Else
                TEnext.TEMPOEVENT = After(TE)
                While TEnext <> NULL
                    If timeOffset >= TEnext\tics Then Exit
                    TEnext = After(TEnext)
                Wend
                If TEnext <> NULL Then
                    TE = TEnext
                EndIf
                msOffset = TE\ms+(timeOffset-TE\tics)*TE\fact
            EndIf
            bb = ReadByte(f)
            If bb Shr 7 Then
                msgType = bb
            Else
                SeekFile f, FileOffset(f)-1
            EndIf
            If msgType = $FF Then
                //metadataa
                Dim metaType As Byte
                offset = FileOffset(f)
                metaType = ReadByte(f)
                Select metaType
                    Case $00 // sequence number
                        l = ReadVarLen(f)
                        If l<>2 Then Return Error(f,"Invalid sequence number length ("+l+")")
                        sequenceNumber(0) = ReadByte(f)
                        sequenceNumber(1) = ReadByte(f)
                    Case $01 // text event
                        tmpString = ReadString2(f)
                    Case $02 // copyright notice
                        tmpString = ReadString2(f)
                    Case $03 // sequence/track name
                        nT\name = ReadString2(f)
                    Case $04 // instrument name
                        nT\instrument = ReadString2(f)
                    Case $05 // lyrics
                        lyrics = ReadString2(f)
                    Case $06 // marker
                        tmpString = ReadString2(f)
                    Case $07 // cue point
                        tmpString = ReadString2(f)
                    Case $20 // MIDI channel prefix
                        tmpInt = ReadVarLen(f)
                        If tmpInt > 4 Then Error(f, "Invalid MIDI channel prefix event at 0x"+Right(Hex(offset),4))
                        tmpInt=ReadBytes(f,tmpInt)
                    Case $21 // MIDI port
                        tmpInt = ReadVarLen(f)
                        If tmpInt > 4 Then Error(f,"Invalid MIDI port event at 0x"+Right(Hex(offset),4))
                        tmpInt=ReadBytes(f,tmpInt)
                    Case $2F // end of track
                        tmpByte=ReadByte(f)
                        If tmpByte <> 0 Then Error(f,"Invalid End of Track event at 0x"+Right(Hex(offset),4))
                    Case $51 // set tempo
                        tmpInt = ReadVarLen(f)
                        If tmpInt <> 3 Then Error(f,"Invalid tempo event at 0x"+Right(Hex(offset),4))
                        microSecsPerQuarterNote=ReadBytes(f,tmpInt)
                        ms = 0 : tics = 0 : fact#=1
                        If TE <> NULL Then ms = TE\ms : tics = TE\tics : fact = TE\fact
                        nTE.TEMPOEVENT = New(TEMPOEVENT)
                        nTE\tics = timeOffset
                        nTE\ms   = ms+(nTE\tics-tics)*fact
                        nTE\fact = (microSecsPerQuarterNote / timeDiv / 1000.0)
                        nTE\bpm  = (60000000.0/microSecsPerQuarterNote)
                        If TE <> NULL Then
                            TE\nextEventPtr = ConvertToInteger(nTE)
                            TE\nextEventMs = nTE\ms
                        EndIf
                        TE = nTE
                    Case $54 // smpte offset
                        tmpInt = ReadVarLen(f)
                        If tmpInt <> 5 Then Error(f,"Invalid SMPTE offset event at 0x"+Right(Hex(offset),4))
                        SecOffset = ReadByte(f)*3600+ReadByte(f)*60+ReadByte(f)
                        FrameOffset = ReadByte(f)*100 + ReadByte(f)
                    Case $58 // time signature
                        tmpInt = ReadVarLen(f)
                        If tmpInt <> 4 Then Error(f,"Invalid time signature event at 0x"+Right(Hex(offset),4))
                        p1 = ReadByte(f)
                        p2 = ReadByte(f)
                        p3 = ReadByte(f)
                        p4 = ReadByte(f)
                    Case $59 // key signature
                        tmpInt = ReadVarLen(f)
                        If tmpInt <> 2 Then Error(f,"Invalid key signature event at 0x"+Right(Hex(offset),4))
                        sf = ReadByte(f)
                        MajorMinor = ReadByte(f)
                    Case $7F // sequencer specific
                        tmpInt = ReadVarLen(f)
                        SeekFile f, FileOffset(f)+tmpInt
                    Default
                        //Error(f, "Unknown meta event 0x"+Right(Hex(metaType),2)+" at 0x"+Right(Hex(offset),4)+Chr(13)+"Length: "+ReadVarLen(f))
                        l=ReadVarLen(f)
                        //SeekFile f, FileOffset(f)+1
                End Select
            ElseIf msgType Shr 4 = $F Then
                ll = ReadVarLen(f)
                For asd=1 To ll
                    bb=ReadByte(f)
                Next asd
            ElseIf msgType > 0 Then
                Dim param1 As Byte, param2 As Byte
                eventType = (msgType Shr 4)
                midiCh    = (msgType Shl 28) Shr 28
                param1 = ReadByte(f)
                If (eventType >= $8 And eventType <= $B) Or eventType = $E Then param2 = ReadByte(f)
                Select eventType
                    Case $8 // 1000 | note off           | (note, velocity)
                        For nN.NOTES = Each NOTES
                            If nN\length = -1 And nN\note = param1 Then
                                If nN\track = a And nN\channel = midiCh Then
                                    nN\length = Max(0,msOffset - nN\start)
                                    Exit
                                EndIf
                            EndIf
                        Next nN
                    Case $9 // 1001 | note on            | (note, velocity)
                        velocity = param2*trackVolume/127.0
                        If velocity = 0 Then
                            For nN.NOTES = Each NOTES
                                If nN\length = -1 And nN\note = param1 Then
                                    If nN\track = a And nN\channel = midiCh Then
                                        nN\length = Max(0,msOffset - nN\start)
                                        Exit
                                    EndIf
                                EndIf
                            Next nN
                        Else
                            nN.NOTES    = New(NOTES)
                            nN\channel  = midiCh
                            nN\track    = a
                            nN\trackPtr = trackPtr
                            nN\note     = param1
                            nN\velocity = velocity
                            nN\start    = msOffset
                            nN\length   = -1
                            nN\lyrics   = lyrics
                            If nN\note > nT\maxNote Then nT\maxNote = nN\note
                            If nN\note < nT\minNote Then nT\minNote = nN\note
                        EndIf
                    Case $A // 1010 | note aftertouch    | (note, velocity)
                        event = NOTE_AFTERTOUCH
                    Case $B // 1011 | controller event   | (controller, value)
                        event = CONTROLLER_EVENT
                        If param1 = 7 Then trackVolume = param2
                        //Print param1+":"+controllerEvent(param1)
                    Case $C // 1100 | program change     | (program)
                        event = PROGRAM_CHANGE
                    Case $D // 1101 | channel aftertouch | (amount = 0,127)
                        event = CHANNEL_AFTERTOUCH
                    Case $E // 1110 | pitch bend         | (lsb, msb)
                        event = PITCH_BEND
                        n = getBytes(param1,0,6)+(getBytes(param2,0,6) Shl 7)-8192
                    Case $F // sysEx (jostain syystä ei handlattu jo aiemmin :d)
                        tmpInt = readBytes(f,ReadVarLen(f))
                    Default
                        Error(f, "Unknown event 0x"+Right(Hex(eventType),2)+" at 0x"+Right(Hex(offset),4))
                End Select
            EndIf
        Wend
    Next a
    
    CloseFile f
    Return mem
End Function

Function ReadString2(f)
    Dim ret As String
    l = ReadVarLen(f)
    For i = 1 To l
        ret = ret + Chr(ReadByte(f))
    Next i
    Return ret
End Function

Function Error(f As Integer = 0, strError As String = "")
    If f Then CloseFile f
    If strError <> "" Then MakeError StrError
    Return False
End Function

Function ReadShort2(f As Integer)
    Return (ReadByte(f) Shl 8 + ReadByte(f))
End Function

Function ReadInt2(f As Integer)
    Return (ReadByte(f) Shl 24 + ReadByte(f) Shl 16 + ReadByte(f) Shl 8 + ReadByte(f))
End Function

Function ReadBytes(f As Integer, amount As Integer)
    Dim ret As Integer, i As Integer
    For i = amount-1 To 0 Step -1
        ret = ret + ReadByte(f) Shl (i Shl 3)
    Next i
    Return ret
End Function

Function ReadVarLen(f As Integer)
    a=ReadByte(f)
    If a Shr 7 Then
        b=ReadByte(f)
        If b Shr 7 Then 
            c=ReadByte(f)
            If c Shr 7 Then
                Return (((a-128) Shl 7 +b-128) Shl 7 + c -128 ) Shl 7 + ReadByte(f)
            Else
                Return ((a-128) Shl 7 +b-128) Shl 7 + c
            EndIf
        Else
            Return (a-128) Shl 7 +b
        EndIf
    Else
        Return a
    EndIf
EndFunction

Function getBytes(n, startId, endId)
    l=(endId-startId+1)
    n=(n Shl (32-startId-l))
    n=(n Shr (32-l))
    Return n
End Function

User avatar
valscion
Moderator
Moderator
Posts: 1587
Joined: Thu Dec 06, 2007 8:46 pm
Location: Espoo
Contact:

Re: Efektit

Post by valscion » Wed Mar 23, 2011 11:21 pm

Valtzu wrote:Teinpä midinluku-systeemin, jota voi käyttää apuna esim. introissa/demoissa jne. Käyttää (normaalisti) Windowsin mukana tulevaa town.midiä.
U-P-E-A! Tästä tulee varmasti olemaan apua, jos joskus aikoo toteuttaa intron midien avulla :)

Lisäsin sen tuonne omaan "koodikirjastooni" (eli siis tänne) ettei se vain huku tänne efektit-topikkiin jos joskus tuleekin tarvetta ;)
cbEnchanted, uudelleenkirjoitettu runtime. Uusin versio: 0.4.1 — Nyt myös sorsat GitHubissa!
NetMatch - se kunnon nettimättö-deathmatch! Avoimella lähdekoodilla varustettu
vesalaakso.com

User avatar
TukeKoodi
Active Member
Posts: 142
Joined: Thu Feb 03, 2011 8:40 pm
Location: C:\Työpöytä

Re: Efektit

Post by TukeKoodi » Thu Mar 24, 2011 8:30 am

Valtzu wrote:Teinpä midinluku-systeemin, jota voi käyttää apuna esim. introissa/demoissa jne. Käyttää (normaalisti) Windowsin mukana tulevaa town.midiä.
No tämähän vallan hieno systeemi on. Tätä luultavasti tulee tarvitsemaankin :)
Aloittelija, koodaaja, jotain...
CbFUN :D

User avatar
Misthema
Advanced Member
Posts: 312
Joined: Mon Aug 27, 2007 8:32 pm
Location: Turku, Finland
Contact:

Re: Efektit

Post by Misthema » Sat Mar 26, 2011 4:39 pm

Tylsyyden iskiessä tein simppelin 'text-scroller':n.

Code: Select all

Randomize Timer() 'Alustetaan satunnaislukugeneraattori

Type SCR 'SCROLLER
    Field char$ 'Kirjain
    Field x# 'X-koordinaatti
    Field y# 'Y-koordinaatti
    Field c 'Väri
    Field t 'Värityyppi
End Type

'Esimerkkiteksti
teksti$="... Tässä teille tällainen peisikki-teksti-skrolleri! ... Heheheheee! Hullun siisti, joo'o, on on! ... Terv. misthema ..."

'Käydään läpi kaikki kirjaimet teksti-muuttujasta
' ja luodaan niistä tyypin SCR jäseniä
For i=0 To Len(teksti)
    ch.SCR=New(SCR)             'Luodaan uusi jäsen
    ch\char=Mid(teksti,i+1,1)   'Annetaan kirjain
    ch\x=400+i*TextWidth("X")   'X-koordinaatti
    ch\y=100+Sin(ch\x)*10       'Y-koordinaatti
    ch\c=(i*25) Mod 255         'Aloitus väri
    ch\t=0                      'Aloitus värityyppi
Next i

'Päälooppi, kunnes ESC
While Not KeyDown(1)
   
    'Käydään läpi luodut kirjaimet
    For ch2.SCR = Each SCR
        ch2\y=100+Sin(ch2\x*2)*15   'Liikutetaan tekstiä ylös ja alas
        ch2\x=ch2\x-1               'Liikutetaan tekstiä vasemmalle
       
        'Jos kirjain menee ruudun ulkopuolelle, heitetään se takaisin alkuun (yli oikean reunan)
        If ch2\x<-TextWidth("X") Then ch2\x=ScreenWidth()/2+TextWidth(teksti)

        ch2\c=ch2\c-3 'Säädetään väriskaalaajaa
        If ch2\c<=0 Then
            ch2\c=255 '...ja takaisin
            ch2\t=(ch2\t+1) Mod 4 'Muutetaan värityyppiä
        EndIf
       
        Select ch2\t 'Asetetaan kirjaimen väri värityypin mukaan
            Case 0
                Color ch2\c,0,0
            Case 1
                Color 0,ch2\c,0
            Case 2
                Color 0,0,ch2\c
            Case 3
                Color 0,255-ch2\c,ch2\c
        End Select
        
        'Jos kirjain ei ole vielä ruudulla, sitä ei piirretä
        If ch2\x<ScreenWidth() Then
            Text ch2\x,ch2\y,ch2\char 'Piirretään kirjain ruudulle
        EndIf
    Next ch2
    
    SetWindow Str(FPS())
   
    DrawScreen
   
Wend
Last edited by Misthema on Sat Mar 26, 2011 6:27 pm, edited 1 time in total.

User avatar
valscion
Moderator
Moderator
Posts: 1587
Joined: Thu Dec 06, 2007 8:46 pm
Location: Espoo
Contact:

Re: Efektit

Post by valscion » Sat Mar 26, 2011 5:08 pm

Misthema wrote:Tylsyyden iskiessä tein simppelin 'text-scroller':n.
Aika näppärä ja siisti, mutta on liian FPS-riippuvainen. Pitäis toimia tuo liukuminen Timer:n avulla, koska nyt tuo menee epätasaisesti ja nopeus riippuu aina ruudulla olevasta tekstin määrästä.
cbEnchanted, uudelleenkirjoitettu runtime. Uusin versio: 0.4.1 — Nyt myös sorsat GitHubissa!
NetMatch - se kunnon nettimättö-deathmatch! Avoimella lähdekoodilla varustettu
vesalaakso.com

User avatar
Misthema
Advanced Member
Posts: 312
Joined: Mon Aug 27, 2007 8:32 pm
Location: Turku, Finland
Contact:

Re: Efektit

Post by Misthema » Sat Mar 26, 2011 6:29 pm

Eipä ole meikäläisellä hallussa nuo tweenit eikä intervallit.. =/
Muokkailin kuitenkin koodia sen verran, että tekstiä ei piirretä ennen kuin se on juuri tulossa ruudun piirtoalueelle.
Joku ken osaa, voisi väsätä tweenaukset tuohon. Jos vaikka itsekin oppisi jotain. =)

User avatar
Latexi95
Guru
Posts: 1164
Joined: Sat Sep 20, 2008 5:10 pm
Location: Lempäälä

Re: Efektit

Post by Latexi95 » Sat Mar 26, 2011 10:19 pm

Misthema wrote:Eipä ole meikäläisellä hallussa nuo tweenit eikä intervallit.. =/
Muokkailin kuitenkin koodia sen verran, että tekstiä ei piirretä ennen kuin se on juuri tulossa ruudun piirtoalueelle.
Joku ken osaa, voisi väsätä tweenaukset tuohon. Jos vaikka itsekin oppisi jotain. =)
Tässäpä Timeria käyttävä FPS:stä riippumaton versio:

Code: Select all

'Montako pikseliä tekstiä liikutetaan sekunnissa
Const MovingPerSecond = 40.0
'Värinmuutos sekunnissa
Const ColorChangePerSecond = 200.0

Randomize Timer() 'Alustetaan satunnaislukugeneraattori

Type SCR 'SCROLLER
    Field char$ 'Kirjain
    Field x# 'X-koordinaatti
    Field y# 'Y-koordinaatti
    Field c# 'Väri
    Field t 'Värityyppi
End Type

'Esimerkkiteksti
teksti$="... Tässä teille tällainen peisikki-teksti-skrolleri! ... Heheheheee! Hullun siisti, joo'o, on on! ... Terv. misthema ..."

'Käydään läpi kaikki kirjaimet teksti-muuttujasta
' ja luodaan niistä tyypin SCR jäseniä
For i=0 To Len(teksti)
    ch.SCR=New(SCR)             'Luodaan uusi jäsen
    ch\char=Mid(teksti,i+1,1)   'Annetaan kirjain
    ch\x=400+i*TextWidth("X")   'X-koordinaatti
    ch\y=100+Sin(ch\x)*10       'Y-koordinaatti
    ch\c=(i*25) Mod 255         'Aloitus väri
    ch\t=0                      'Aloitus värityyppi
Next i

'Edellisen päivityskerran aika
lastUpdate = Timer()

'Päälooppi, kunnes ESC
While Not KeyDown(1)
   
    'lasketaan ajan kulumisen mukaan kerroin
    updateTimeMultiplier# = Float(Timer() - lastUpdate)/1000.0
    
    'Edellisen päivityskerran aika
    lastUpdate = Timer()
    'Käydään läpi luodut kirjaimet
    For ch2.SCR = Each SCR
        ch2\y=100+Sin(ch2\x*2)*15                               'Liikutetaan tekstiä ylös ja alas
        ch2\x=ch2\x-updateTimeMultiplier*MovingPerSecond        'Liikutetaan tekstiä vasemmalle
       
        'Jos kirjain menee ruudun ulkopuolelle, heitetään se takaisin alkuun (yli oikean reunan)
        If ch2\x<-TextWidth("X") Then ch2\x=ScreenWidth()/2+TextWidth(teksti)

        ch2\c=ch2\c-ColorChangePerSecond*updateTimeMultiplier 'Säädetään väriskaalaajaa
        If ch2\c<=0 Then
            ch2\c=255 '...ja takaisin
            ch2\t=(ch2\t+1) Mod 4 'Muutetaan värityyppiä
        EndIf
       
        Select ch2\t 'Asetetaan kirjaimen väri värityypin mukaan
            Case 0
                Color ch2\c,0,0
            Case 1
                Color 0,ch2\c,0
            Case 2
                Color 0,0,ch2\c
            Case 3
                Color 0,255-ch2\c,ch2\c
        End Select
       
        'Jos kirjain ei ole vielä ruudulla, sitä ei piirretä
        If ch2\x<ScreenWidth() Then
            Text ch2\x,ch2\y,ch2\char 'Piirretään kirjain ruudulle
        EndIf
    Next ch2
   
    SetWindow Str(FPS())
   
    DrawScreen
   
Wend

User avatar
MaGetzUb
Guru
Posts: 1715
Joined: Sun Sep 09, 2007 12:35 pm
Location: Alavus

Re: Efektit

Post by MaGetzUb » Sun Mar 27, 2011 1:20 am

Keskiyön koodailua.. :D

Code: Select all

Const SW = 640
Const SH = 480
SCREEN SW, SH

Const GW = 35
Const GH = 35

FieldSize = Sqrt(SW*SW + SH*SH)
Repeat 
    a = a + 1
    For x = 0 To FieldSize Step GW
        For y = 0 To FieldSize Step GH
        px = Cos(a) * (FieldSize/2-x) + Sin(a) * (FieldSize/2-y)
        py = Sin(a) * (FieldSize/2-x) - Cos(a) * (FieldSize/2-y)
        Color 127+Sin(a*2+Sin(a)*px+Cos(a)*py)*127, 127+Sin(a*2+px+120+Sin(a)*px+Cos(a)*py)*127, 127+Cos(a*2+px+240+Sin(a)*px+Sin(a)*py)*127
        Circle SW/2+px-GW/2, SH/2+py-GW/2, GW, Int(Sin(a*2+Sin(a)*px+Cos(a)*py))
        Next y 
    Next x
DrawScreen Not MouseDown(1)
Forever 
Solar Eclipse
Meneillä olevat Projektit:
We're in a simulation, and God is trying to debug us.

User avatar
ukkeli
Active Member
Posts: 123
Joined: Thu Jan 28, 2010 10:01 pm

Re: Efektit

Post by ukkeli » Sun Mar 27, 2011 12:41 pm

MaGetzUb wrote:Keskiyön koodailua.. :D

Code: Select all

hyvä efecti
Hmm... Tuo on hyvä. Kannattaa laittaa, että välillä kamera liikkuisi ihan johonkin suuntaan ja kääntyisi toiseen. Näin se olisi vielä parempi!
...

User avatar
Misthema
Advanced Member
Posts: 312
Joined: Mon Aug 27, 2007 8:32 pm
Location: Turku, Finland
Contact:

Re: Efektit

Post by Misthema » Sun Mar 27, 2011 8:10 pm

Meh.. Kun on tylsää, sitä voi syntyä vaikka mitä:

Code: Select all

SCREEN 800,600
SCREEN 40,20, 32, cbSizable 'Muuta resoluutiota (imho max. 640x480 on paras)
Randomize Timer()
'FrameLimit 10

'Montako pikseliä tekstiä liikutetaan sekunnissa
Const MPS = 40.0
'Värinmuutos sekunnissa
Const APS = 50.0
'Aikaväli jolloin ruutu piirretään
Const lpdTimer = 10 'millisekunteina

Type BUBBLES
    Field x#
    Field y#
    Field dir%
    Field speed#
EndType

Type BLOW
    Field x#
    Field y#
    Field yvel#
    Field ang#
    Field c#
EndType

Dim ord(6, 3)
 
ord(1, 1) = 1 : ord(1, 2) = 2 : ord(1, 3) = 3
ord(2, 1) = 1 : ord(2, 2) = 3 : ord(2, 3) = 2
ord(3, 1) = 2 : ord(3, 2) = 1 : ord(3, 3) = 3
ord(4, 1) = 2 : ord(4, 2) = 3 : ord(4, 3) = 1
ord(5, 1) = 3 : ord(5, 2) = 1 : ord(5, 3) = 2
ord(6, 1) = 3 : ord(6, 2) = 2 : ord(6, 3) = 1

pipe=MakePipe()
pipe2=MakePipe2()
bubble=MakeBubble()
bubbleTimer=Timer()
yh=ScreenHeight()/4

'Edellisen päivityskerran aika
lastUpdate = Timer()

drawTimer=Timer()
loops=0

While Not KeyDown(1)

    'lasketaan ajan kulumisen mukaan kerroin
    updateTimeMultiplier# = Float(Timer() - lastUpdate)/1000.0
   
    'Edellisen päivityskerran aika
    lastUpdate = Timer()

Cls
    If Timer()>bubbleTimer+Rand(100,500) Then
        bub.BUBBLES=New(BUBBLES)
        bub\x=Rand(ScreenWidth())-ImageWidth(bubble)
        bub\y=ScreenHeight()
        bub\dir=Rand(1)
        bub\speed=Rnd(MPS/4,MPS)
        bubbleTimer=Timer()
    EndIf
    
    ccc#=WrapAngle(ccc+(updateTimeMultiplier*APS))
    angle#=WrapAngle(angle+Sin(ccc)*(updateTimeMultiplier*200.0))
    
    
    
    For y=0 To yh
        y2=angle+y
        yy= y Shl 2

		z1# = Sin(y2)
		z2# = Sin(y2 + 120)
		z3# = Sin(y2 + 240)
 
		If (z1 > z2 And z2 > z3) Then
			order = 1
		ElseIf (z1 > z3 And z3 > z2) Then
			order = 2
		ElseIf (z2 > z1 And z1 > z3) Then
			order = 3
		ElseIf (z2 > z3 And z3 > z1) Then
			order = 4
		ElseIf (z3 > z1 And z1 > z2) Then
			order = 5
		Else
			order = 6
		EndIf
        
        
        x=ImageWidth(pipe)
        p2x=ScreenWidth()-(x*2)
        
 
		DrawImageBox pipe, x + Sin(y2 + ord(order, 1) * 120) * x, yy, 0, yy, x, 4
		DrawImageBox pipe, x + Sin(y2 + ord(order, 2) * 120) * x, yy, 0, yy, x, 4
		DrawImageBox pipe, x + Sin(y2 + ord(order, 3) * 120) * x, yy, 0, yy, x, 4
        DrawImageBox pipe2, p2x - Sin(y2 + ord(order, 1) * 120) * x, yy, 0, yy, x, 4
		DrawImageBox pipe2, p2x - Sin(y2 + ord(order, 2) * 120) * x, yy, 0, yy, x, 4
		DrawImageBox pipe2, p2x - Sin(y2 + ord(order, 3) * 120) * x, yy, 0, yy, x, 4
    Next y
        
        
    
    For bubb.BUBBLES = Each BUBBLES
        bubb\y=bubb\y-(updateTimeMultiplier*bubb\speed)
        If bubb\dir Then
            bubb\x=bubb\x+Sin(bubb\y)*(updateTimeMultiplier*25.0)
        Else
            bubb\x=bubb\x+Sin(bubb\y)*-(updateTimeMultiplier*25.0)
        EndIf
        If bubb\y<ScreenHeight()/5 Then
            xplus#=ImageWidth(bubble)/2
            BubbleBlow(bubb\x+xplus,bubb\y+xplus)
            Delete bubb
        EndIf
        
        DrawImage bubble,bubb\x,bubb\y
    Next bubb
    
    For bl.BLOW = Each BLOW
        bl\x=bl\x+Cos(bl\ang)*(updateTimeMultiplier*25.0)
        bl\yvel=bl\yvel+(updateTimeMultiplier*1.0)
        bl\y=(bl\y+Sin(bl\ang)*(updateTimeMultiplier*25.0))+bl\yvel
        
        bl\c=bl\c-(updateTimeMultiplier*200.0)
        
        If bl\c<=2 Then
            Delete bl
        EndIf
        
        Color cblightblue
        Dot bl\x,bl\y
    Next bl
    
    SetWindow Str(FPS())+" | Loops before draw: "+loops
    If Timer()>drawTimer+lpdTimer
        DrawScreen(0)
        loops=0
        drawTimer=Timer()
    EndIf
    
    loops=loops+1
Wend


Function BubbleBlow(x#,y#)
    For i=0 To 10
        blow.BLOW=New(BLOW)
        blow\ang=Rand(360)
        blow\x=x+Cos(blow\ang)*Rand(5)
        blow\y=y+Sin(blow\ang)*Rand(5)
        blow\c=255.0
    Next i
EndFunction


Function MakeBubble()
    temp=MakeImage(ScreenWidth()/20,ScreenWidth()/20)

    w=ImageWidth(temp)
    w2#=Float(w/1.5)
    
    DrawToImage temp
    
        Color cbblue
        Circle 0,0,w,0
        'Circle 1,1,30,0
        
        Color cblightblue
        Circle w/4,(w/8)-1,w2
        
        Color cbblack
        Circle (w/4)-1,w/8,w2
        
    DrawToScreen
    
    Return temp
EndFunction

Function MakePipe()
    temp=MakeImage(ScreenWidth()/10,ScreenHeight())

    w#=ImageWidth(temp)/8
    
    DrawToImage temp
        For i=0 To 3
            Color i*(255/4),i*(255/4),0
            Box i*w,0,w,ImageHeight(temp)
        Next i
        For i=0 To 3
            Color i*(255/4),i*(255/4),0
            Box (ImageWidth(temp)-w)-i*w,0,w,ImageHeight(temp)
        Next i
    DrawToScreen
    
    Return temp
EndFunction
    
Function MakePipe2()
    temp=MakeImage(ScreenWidth()/10,ScreenHeight())

    w#=ImageWidth(temp)/8

    DrawToImage temp
        For i=0 To 3
            Color i*(255/4),0,i*(255/4)
            Box i*w,0,w,ImageHeight(temp)
        Next i
        For i=0 To 3
            Color i*(255/4),0,i*(255/4)
            Box (ImageWidth(temp)-w)-i*w,0,w,ImageHeight(temp)
        Next i
    DrawToScreen
    
    Return temp
EndFunction
Muutelkaa resoluutiota, lpdTimer:ia ja framelimittiä. Tällaisen resoluutio-/FPS-riippumattoman ehvektin yritin tehdä siis.

User avatar
valscion
Moderator
Moderator
Posts: 1587
Joined: Thu Dec 06, 2007 8:46 pm
Location: Espoo
Contact:

Re: Efektit

Post by valscion » Sun Mar 27, 2011 9:46 pm

Misthema wrote:Meh.. Kun on tylsää, sitä voi syntyä vaikka mitä:

Code: Select all

Awesomeness
Muutelkaa resoluutiota, lpdTimer:ia ja framelimittiä. Tällaisen resoluutio-/FPS-riippumattoman ehvektin yritin tehdä siis.
Upea! En uskonut silmiäni kun muutin reson 800x600 :shock: FPS:kin pysyi siinä resossa vielä 60:ssä.
En malttanut olla lisäämättä pallojen poksuttelua tuohon efektiin, joten tässä olisi hiiri pohjassa toimiva poksuttelu :D

Code: Select all

SCREEN 800,600
SCREEN 640,480, 32, cbSizable 'Muuta resoluutiota (imho max. 640x480 on paras)
Randomize Timer()
'FrameLimit 10

'Montako pikseliä tekstiä liikutetaan sekunnissa
Const MPS = 40.0
'Värinmuutos sekunnissa
Const APS = 50.0
'Aikaväli jolloin ruutu piirretään
Const lpdTimer = 10 'millisekunteina

Type BUBBLES
    Field x#
    Field y#
    Field dir%
    Field speed#
EndType

Type BLOW
    Field x#
    Field y#
    Field yvel#
    Field ang#
    Field c#
EndType

Dim ord(6, 3)

ord(1, 1) = 1 : ord(1, 2) = 2 : ord(1, 3) = 3
ord(2, 1) = 1 : ord(2, 2) = 3 : ord(2, 3) = 2
ord(3, 1) = 2 : ord(3, 2) = 1 : ord(3, 3) = 3
ord(4, 1) = 2 : ord(4, 2) = 3 : ord(4, 3) = 1
ord(5, 1) = 3 : ord(5, 2) = 1 : ord(5, 3) = 2
ord(6, 1) = 3 : ord(6, 2) = 2 : ord(6, 3) = 1

pipe=MakePipe()
pipe2=MakePipe2()
bubble=MakeBubble()
bubbleTimer=Timer()
yh=ScreenHeight()/4

bubbleRad = ImageWidth(bubble)/2

'Edellisen päivityskerran aika
lastUpdate = Timer()

drawTimer=Timer()
loops=0

While Not KeyDown(1)

    'lasketaan ajan kulumisen mukaan kerroin
    updateTimeMultiplier# = Float(Timer() - lastUpdate)/1000.0
   
    'Edellisen päivityskerran aika
    lastUpdate = Timer()

Cls
    If Timer()>bubbleTimer+Rand(100,500) Then
        bub.BUBBLES=New(BUBBLES)
        bub\x=Rand(ScreenWidth())-ImageWidth(bubble)
        bub\y=ScreenHeight()
        bub\dir=Rand(1)
        bub\speed=Rnd(MPS/4,MPS)
        bubbleTimer=Timer()
    EndIf
   
    ccc#=WrapAngle(ccc+(updateTimeMultiplier*APS))
    angle#=WrapAngle(angle+Sin(ccc)*(updateTimeMultiplier*200.0))
   
   
   
    For y=0 To yh
        y2=angle+y
        yy= y Shl 2

      z1# = Sin(y2)
      z2# = Sin(y2 + 120)
      z3# = Sin(y2 + 240)

      If (z1 > z2 And z2 > z3) Then
         order = 1
      ElseIf (z1 > z3 And z3 > z2) Then
         order = 2
      ElseIf (z2 > z1 And z1 > z3) Then
         order = 3
      ElseIf (z2 > z3 And z3 > z1) Then
         order = 4
      ElseIf (z3 > z1 And z1 > z2) Then
         order = 5
      Else
         order = 6
      EndIf
       
       
        x=ImageWidth(pipe)
        p2x=ScreenWidth()-(x*2)
       

      DrawImageBox pipe, x + Sin(y2 + ord(order, 1) * 120) * x, yy, 0, yy, x, 4
      DrawImageBox pipe, x + Sin(y2 + ord(order, 2) * 120) * x, yy, 0, yy, x, 4
      DrawImageBox pipe, x + Sin(y2 + ord(order, 3) * 120) * x, yy, 0, yy, x, 4
        DrawImageBox pipe2, p2x - Sin(y2 + ord(order, 1) * 120) * x, yy, 0, yy, x, 4
      DrawImageBox pipe2, p2x - Sin(y2 + ord(order, 2) * 120) * x, yy, 0, yy, x, 4
      DrawImageBox pipe2, p2x - Sin(y2 + ord(order, 3) * 120) * x, yy, 0, yy, x, 4
    Next y
       
       
   
    For bubb.BUBBLES = Each BUBBLES
        bubb\y=bubb\y-(updateTimeMultiplier*bubb\speed)
        If bubb\dir Then
            bubb\x=bubb\x+Sin(bubb\y)*(updateTimeMultiplier*25.0)
        Else
            bubb\x=bubb\x+Sin(bubb\y)*-(updateTimeMultiplier*25.0)
        EndIf
        If bubb\y<ScreenHeight()/5 Or ( MouseDown(1) And Abs(MouseX()-bubb\x-bubbleRad)<bubbleRad And Abs(MouseY()-bubb\y-bubbleRad)<bubbleRad ) Then
            xplus#=ImageWidth(bubble)/2
            BubbleBlow(bubb\x+xplus,bubb\y+xplus)
            Delete bubb
        EndIf
       
        DrawImage bubble,bubb\x,bubb\y
    Next bubb
   
    For bl.BLOW = Each BLOW
        bl\x=bl\x+Cos(bl\ang)*(updateTimeMultiplier*25.0)
        bl\yvel=bl\yvel+(updateTimeMultiplier*1.0)
        bl\y=(bl\y+Sin(bl\ang)*(updateTimeMultiplier*25.0))+bl\yvel
       
        bl\c=bl\c-(updateTimeMultiplier*200.0)
       
        If bl\c<=2 Then
            Delete bl
        EndIf
       
        Color cblightblue
        Dot bl\x,bl\y
    Next bl
   
    SetWindow Str(FPS())+" | Loops before draw: "+loops
    If Timer()>drawTimer+lpdTimer
        DrawScreen(0)
        loops=0
        drawTimer=Timer()
    EndIf
   
    loops=loops+1
Wend


Function BubbleBlow(x#,y#)
    For i=0 To 10
        blow.BLOW=New(BLOW)
        blow\ang=Rand(360)
        blow\x=x+Cos(blow\ang)*Rand(5)
        blow\y=y+Sin(blow\ang)*Rand(5)
        blow\c=255.0
    Next i
EndFunction


Function MakeBubble()
    temp=MakeImage(ScreenWidth()/20,ScreenWidth()/20)

    w=ImageWidth(temp)
    w2#=Float(w/1.5)
   
    DrawToImage temp
   
        Color cbblue
        Circle 0,0,w,0
        'Circle 1,1,30,0
       
        Color cblightblue
        Circle w/4,(w/8)-1,w2
       
        Color cbblack
        Circle (w/4)-1,w/8,w2
       
    DrawToScreen
   
    Return temp
EndFunction

Function MakePipe()
    temp=MakeImage(ScreenWidth()/10,ScreenHeight())

    w#=ImageWidth(temp)/8
   
    DrawToImage temp
        For i=0 To 3
            Color i*(255/4),i*(255/4),0
            Box i*w,0,w,ImageHeight(temp)
        Next i
        For i=0 To 3
            Color i*(255/4),i*(255/4),0
            Box (ImageWidth(temp)-w)-i*w,0,w,ImageHeight(temp)
        Next i
    DrawToScreen
   
    Return temp
EndFunction
   
Function MakePipe2()
    temp=MakeImage(ScreenWidth()/10,ScreenHeight())

    w#=ImageWidth(temp)/8

    DrawToImage temp
        For i=0 To 3
            Color i*(255/4),0,i*(255/4)
            Box i*w,0,w,ImageHeight(temp)
        Next i
        For i=0 To 3
            Color i*(255/4),0,i*(255/4)
            Box (ImageWidth(temp)-w)-i*w,0,w,ImageHeight(temp)
        Next i
    DrawToScreen
   
    Return temp
EndFunction
Tein vielä toisenkin, jossa toimii hiiren kakkosnapikalla ikkunan leveydeltä joku ihme laser-hommeli joka tuhoaa kaikki sen tielle osuvat pallot.

Code: Select all

SCREEN 800,600
SCREEN 640,480, 32, cbSizable 'Muuta resoluutiota (imho max. 640x480 on paras)
Randomize Timer()
'FrameLimit 10

'Montako pikseliä tekstiä liikutetaan sekunnissa
Const MPS = 40.0
'Värinmuutos sekunnissa
Const APS = 50.0
'Aikaväli jolloin ruutu piirretään
Const lpdTimer = 10 'millisekunteina

Type BUBBLES
    Field x#
    Field y#
    Field dir%
    Field speed#
EndType

Type BLOW
    Field x#
    Field y#
    Field yvel#
    Field ang#
    Field c#
EndType

Dim ord(6, 3)

ord(1, 1) = 1 : ord(1, 2) = 2 : ord(1, 3) = 3
ord(2, 1) = 1 : ord(2, 2) = 3 : ord(2, 3) = 2
ord(3, 1) = 2 : ord(3, 2) = 1 : ord(3, 3) = 3
ord(4, 1) = 2 : ord(4, 2) = 3 : ord(4, 3) = 1
ord(5, 1) = 3 : ord(5, 2) = 1 : ord(5, 3) = 2
ord(6, 1) = 3 : ord(6, 2) = 2 : ord(6, 3) = 1

pipe=MakePipe()
pipe2=MakePipe2()
bubble=MakeBubble()
bubbleTimer=Timer()
yh=ScreenHeight()/4

bubbleRad = ImageWidth(bubble)/2

'Edellisen päivityskerran aika
lastUpdate = Timer()

drawTimer=Timer()
loops=0

While Not KeyDown(1)

    'lasketaan ajan kulumisen mukaan kerroin
    updateTimeMultiplier# = Float(Timer() - lastUpdate)/1000.0
   
    'Edellisen päivityskerran aika
    lastUpdate = Timer()

Cls
    If Timer()>bubbleTimer+Rand(100,500) Then
        bub.BUBBLES=New(BUBBLES)
        bub\x=Rand(ScreenWidth())-ImageWidth(bubble)
        bub\y=ScreenHeight()
        bub\dir=Rand(1)
        bub\speed=Rnd(MPS/4,MPS)
        bubbleTimer=Timer()
    EndIf
   
    ccc#=WrapAngle(ccc+(updateTimeMultiplier*APS))
    angle#=WrapAngle(angle+Sin(ccc)*(updateTimeMultiplier*200.0))
   
   
   
    For y=0 To yh
        y2=angle+y
        yy= y Shl 2

      z1# = Sin(y2)
      z2# = Sin(y2 + 120)
      z3# = Sin(y2 + 240)

      If (z1 > z2 And z2 > z3) Then
         order = 1
      ElseIf (z1 > z3 And z3 > z2) Then
         order = 2
      ElseIf (z2 > z1 And z1 > z3) Then
         order = 3
      ElseIf (z2 > z3 And z3 > z1) Then
         order = 4
      ElseIf (z3 > z1 And z1 > z2) Then
         order = 5
      Else
         order = 6
      EndIf
       
       
        x=ImageWidth(pipe)
        p2x=ScreenWidth()-(x*2)
       

      DrawImageBox pipe, x + Sin(y2 + ord(order, 1) * 120) * x, yy, 0, yy, x, 4
      DrawImageBox pipe, x + Sin(y2 + ord(order, 2) * 120) * x, yy, 0, yy, x, 4
      DrawImageBox pipe, x + Sin(y2 + ord(order, 3) * 120) * x, yy, 0, yy, x, 4
        DrawImageBox pipe2, p2x - Sin(y2 + ord(order, 1) * 120) * x, yy, 0, yy, x, 4
      DrawImageBox pipe2, p2x - Sin(y2 + ord(order, 2) * 120) * x, yy, 0, yy, x, 4
      DrawImageBox pipe2, p2x - Sin(y2 + ord(order, 3) * 120) * x, yy, 0, yy, x, 4
    Next y
       
       
   
    For bubb.BUBBLES = Each BUBBLES
        bubb\y=bubb\y-(updateTimeMultiplier*bubb\speed)
        If bubb\dir Then
            bubb\x=bubb\x+Sin(bubb\y)*(updateTimeMultiplier*25.0)
        Else
            bubb\x=bubb\x+Sin(bubb\y)*-(updateTimeMultiplier*25.0)
        EndIf
        If bubb\y<ScreenHeight()/5 Then
            poks = True
        ElseIf MouseDown(1) Then
            If Abs(MouseX()-bubb\x-bubbleRad)<bubbleRad And Abs(MouseY()-bubb\y-bubbleRad)<bubbleRad Then
                poks = True
            Else
                poks = False
            EndIf
        ElseIf MouseDown(2) Then
            Color cbLightYellow
            Box 0, MouseY()-1, ScreenWidth(), 3
            If Abs(MouseY()-bubb\y-bubbleRad)<bubbleRad Then
                poks = True
            Else
                poks = False
            EndIf
        Else
            poks = False
        EndIf
        If poks Then
            xplus#=ImageWidth(bubble)/2
            BubbleBlow(bubb\x+xplus,bubb\y+xplus)
            Delete bubb
        EndIf
       
        DrawImage bubble,bubb\x,bubb\y
    Next bubb
   
    For bl.BLOW = Each BLOW
        bl\x=bl\x+Cos(bl\ang)*(updateTimeMultiplier*25.0)
        bl\yvel=bl\yvel+(updateTimeMultiplier*1.0)
        bl\y=(bl\y+Sin(bl\ang)*(updateTimeMultiplier*25.0))+bl\yvel
       
        bl\c=bl\c-(updateTimeMultiplier*200.0)
       
        If bl\c<=2 Then
            Delete bl
        EndIf
       
        Color cblightblue
        Dot bl\x,bl\y
    Next bl
   
    SetWindow Str(FPS())+" | Loops before draw: "+loops
    If Timer()>drawTimer+lpdTimer
        DrawScreen(0)
        loops=0
        drawTimer=Timer()
    EndIf
   
    loops=loops+1
Wend


Function BubbleBlow(x#,y#)
    For i=0 To 10
        blow.BLOW=New(BLOW)
        blow\ang=Rand(360)
        blow\x=x+Cos(blow\ang)*Rand(5)
        blow\y=y+Sin(blow\ang)*Rand(5)
        blow\c=255.0
    Next i
EndFunction


Function MakeBubble()
    temp=MakeImage(ScreenWidth()/20,ScreenWidth()/20)

    w=ImageWidth(temp)
    w2#=Float(w/1.5)
   
    DrawToImage temp
   
        Color cbblue
        Circle 0,0,w,0
        'Circle 1,1,30,0
       
        Color cblightblue
        Circle w/4,(w/8)-1,w2
       
        Color cbblack
        Circle (w/4)-1,w/8,w2
       
    DrawToScreen
   
    Return temp
EndFunction

Function MakePipe()
    temp=MakeImage(ScreenWidth()/10,ScreenHeight())

    w#=ImageWidth(temp)/8
   
    DrawToImage temp
        For i=0 To 3
            Color i*(255/4),i*(255/4),0
            Box i*w,0,w,ImageHeight(temp)
        Next i
        For i=0 To 3
            Color i*(255/4),i*(255/4),0
            Box (ImageWidth(temp)-w)-i*w,0,w,ImageHeight(temp)
        Next i
    DrawToScreen
   
    Return temp
EndFunction
   
Function MakePipe2()
    temp=MakeImage(ScreenWidth()/10,ScreenHeight())

    w#=ImageWidth(temp)/8

    DrawToImage temp
        For i=0 To 3
            Color i*(255/4),0,i*(255/4)
            Box i*w,0,w,ImageHeight(temp)
        Next i
        For i=0 To 3
            Color i*(255/4),0,i*(255/4)
            Box (ImageWidth(temp)-w)-i*w,0,w,ImageHeight(temp)
        Next i
    DrawToScreen
   
    Return temp
EndFunction
cbEnchanted, uudelleenkirjoitettu runtime. Uusin versio: 0.4.1 — Nyt myös sorsat GitHubissa!
NetMatch - se kunnon nettimättö-deathmatch! Avoimella lähdekoodilla varustettu
vesalaakso.com

User avatar
Wingman
Devoted Member
Posts: 594
Joined: Tue Sep 30, 2008 4:30 pm
Location: Ruudun toisella puolella

Re: Efektit

Post by Wingman » Fri Apr 01, 2011 9:27 am

mm.. yksi tylsä aamu koodaillessa:

Code: Select all

x1#=100
y1#=150
x2#=300
y2#=150
a#=0
av#=0.5
avv#=1
musta=1
Repeat
	For d=400 To 10 Step -20
		For i=0 To 1
			If musta=1 Then 
				Color 1,1,1
				Circle x1-d-i*10,y1-d-i*10,d*2+i*20,1
			EndIf 
			Color 0,Max(0,255-d),255
			Circle x1-d-i*10,y1-d-i*10,d*2+i*20,0
			If musta=1 Then 
				Color 1,1,1
				Circle x2-d-i*10,y2-d-i*10,d*2+i*20,1
			EndIf 
			Color 255,Max(0,255-d),0
			Circle x2-d-i*10,y2-d-i*10,d*2+i*20,0
		Next i
	Next d
	If KeyHit(57) Then musta=Not musta
	a=a+2
	av=CurveValue(avv,av,20)
	If Timer()>t+1000 Then 
		avv=Rnd(-3,3)
		t=Timer()
	EndIf 
	an=WrapAngle(a)
	x1=200+Cos(a)*100
	y1=200-Sin(a)*100
	x2=200-Cos(a)*75
	y2=100+Sin(a)*75
	DrawScreen 
Forever 
Space muuttaa efektiä vähän :)
- - - -

User avatar
Wingman
Devoted Member
Posts: 594
Joined: Tue Sep 30, 2008 4:30 pm
Location: Ruudun toisella puolella

Re: Efektit

Post by Wingman » Sat Apr 02, 2011 4:12 pm

Tuplaposti, mutta eihän tätä muuten kukaan huomaisi :)

Eli siis, päätin tehdä intron jossa taustalla pyörii ainakin yksi metapallo koko ajan. Scrollaus on vähän lyhyt vielä ja musiikki myös, mutta rakenne toimii :)

avoin lähdekoodi, mainitkaahan minut jos käytätte koodia missään

Code: Select all

Const XST=16
Const YST=16
w=720
h=w*9/16
SCREEN w,h,0,1
SCREEN w,h,0,2
start=Timer() 
Type PALLO
	Field x As Float 
	Field y As Float 
	Field kx
	Field ky
	Field s
	Field id
	Field is
EndType 
Type SCROLL
	Field x As Float 
	Field y As Float 
	Field kx
	Field ky
	Field vx As Float 
	Field vy As Float 
	Field lif
	Field tx As String 
EndType 
For i=0 To 0
	p.PALLO=New(PALLO)
	p\x=0
	p\y=h/2
	p\kx=0
	p\ky=p\y
	p\id=pallot+1
	If p\id=1 Then 
		p\s=30
	Else 
		p\s=5
	EndIf 
	pallot+1
Next i
Dim plasm(w,h) As Float 
Dim plasm2(w,h) As Float 
scrolltext$="Yeah, Metaballs metaballs metaballs...          This is an intro, that consists of metaballs.         Had no idea of where this was an intro, or why, but still made this..                 You like meatballs? How about METABALLS!            In the end, this text will just loop. But who cares?         The Song has gone for "+pattern+" patterns, "+tahdit+" measures and "+iskut+" beats. Good Luck!"
xx#=-15
xxx#=-15
rr#=1
gg#=1.5
bb#=2
bpm=130
kk#=30
scrollspeed#=3.1
font=LoadFont("courier new",20)
SetFont font
s.SCROLL=New(SCROLL)
s\x=w
s\y=h-kk-TextHeight("|")
s\vx=-scrollspeed
s\tx=scrolltext
s\lif=1
If FileExists("Untitled.xm")=1 Then 
	PlaySound "Untitled.xm",50 
EndIf 
While 1=1 
	scrolltext$="Yeah, Metaballs metaballs metaballs...          This is an intro, that consists of metaballs.         Had no idea of where this was an intro, or why, but still made this..                 You like meatballs? How about METABALLS!            In the end, this text will just loop. But who cares?         The Song has gone for "+pattern+" patterns, "+tahdit+" measures and "+iskut+" beats. Good Luck!                           You still here? It'll be night soon, you better get away Or you'll be astounded by amazing effects.                            Really, You will.                          Watch out, here it comes...                            NOW!! "
	aika=Timer()-start
	väli=60000/bpm
	tahdit=aika/(väli*4)+1
	pattern=aika/(väli*16)+1
	iskut=aika/väli+1
	tick=aika/(väli/2)+1
	If iskut>ii+1 Then 
		xxx=xxx+XST
		ii=iskut
	EndIf
	xx=CurveValue(xxx,xx,20) 
	If xx>w+15 Then 
		xx=-15
		xxx=-15
		yö+1
		s2.SCROLL=New(SCROLL)
		s2\x=w
		s2\y=h-kk-TextHeight("|")
		s2\vx=-scrollspeed
		s2\tx=scrolltext
		s2\lif=1
	EndIf 
	If yö=1 Then 
		rr=CurveValue(0.25,rr,20)
		gg=CurveValue(0.25,gg,20)
		bb=CurveValue(0.5,bb,20)
	Else 
		rr=CurveValue(1,rr,20)
		gg=CurveValue(1.5,gg,20)
		bb=CurveValue(2,bb,20)
	EndIf 
	If yö>1 Then yö=0
	yy=h/2-Sin(xx/3.2)*100
	Gosub meta
	'If iskut>is Then 
	'	kk=kk+30
	'	is=iskut
	'EndIf 
	'kk=CurveValue(0,kk,10)
	Color 1,50,1
	hh=(h-kk)
	For yyy=hh To hh+YST
		Line 0,yyy,w,yyy
	Next yyy
	SetWindow " "+tahdit+" "+iskut+" "+tick+" "+pattern+" "+Int(xx)
	Gosub scrolli
	DrawScreen 
Wend 

meta:
If tick>ti Then
	p2.PALLO=New(PALLO)
	p2\x=w
	p2\y=Rand(h)
	p2\kx=-w/25
	p2\ky=p2\y
	p2\id=pallot+1
	p2\s=4
	pallot+1
	ti=tick 
EndIf 
For p.PALLO=Each PALLO
	If p\id=1 Then 
		p\x=xx
		p\y=CurveValue(yy,p\y,10)
		p\kx=MouseX()
		p\ky=MouseY()
		If iskut>p\is Then 
			p\y=p\y-10
			p\is=iskut
		EndIf 
	Else
		p\x=p\x+p\kx
		p\y=CurveValue(p\ky,p\y,10)
		If iskut>p\is Then 
			p\y=p\y-30
			p\is=iskut
		EndIf 
	EndIf  
	If p\x<-20 Then Delete p
Next p
For x=0 To w Step XST
	For y=0 To h Step YST
		c=120
		For p.PALLO=Each PALLO
			dis=(120*p\s/(Distance(x,y,p\x,p\y)+1))
			If yö=0 Then 
				If p\id<>1 Then 
					c=c-dis
				Else 
					c=c+dis
				EndIf 
			Else  
				If p\id=1 Then 
					c=c+dis/2
				Else 
					c=c+dis
				EndIf
			EndIf 
		Next p
		c=Min(255,c)
		c=Max(0,c)
		sk=c/25
		If y>h-kk Then
			Color Min(255,0+c*(rr/2)),Min(255,0+c*bb),Min(255,0+c*(rr/2))
		Else  
			Color Min(255,0+c*rr),Min(255,0+c*gg),Min(255,0+c*bb)
		EndIf 
		Box x,y,XST,YST,1
		'Text x,y,asciigrad(sk)
	Next y
Next x
Return 

scrolli:
For s.SCROLL=Each SCROLL
	If yö=0 Then 
		Color 1,1,1
	Else 
		Color 255,255,255
	EndIf 
	s\tx=scrolltext
	Text s\x,s\y,s\tx
	Text s\x+1,s\y,s\tx
	Text s\x,s\y+1,s\tx
	Text s\x+1,s\y+1,s\tx
	s\x+s\vx
	s\y=h-kk-TextHeight("|") 
	If s\x+TextWidth(scrolltext)<0 Then Delete s
Next s
Return 
musiikki täällä, samaan kansioon koodifilun kanssa niin toimii
- - - -

User avatar
MaGetzUb
Guru
Posts: 1715
Joined: Sun Sep 09, 2007 12:35 pm
Location: Alavus

Re: Efektit

Post by MaGetzUb » Sun Apr 03, 2011 8:39 pm

Väsäsimpä aikoinaan tällaisen aaltoiluefektin. Olisi kiva tietää teidän FPS:ät. :)

Code: Select all

//effect by: MaGetzUb 2011

Const SW = 640
Const SH = 480
SCREEN SW, SH
SCREEN SW, SH, 32, 2
//|!!!!!!!!!!!!!!!!!!!!!!!!!!!!|
//säätele arvoja!!!
Global Koko
Global Amplitudi 
Global Kulma
Amplitudi = 20
Koko = 1
Kulma = 0
KulmaNopeus = 2
//|!!!!!!!!!!!!!!!!!!!!!!!!!!!!|


kartta = LoadMap("Media\cdm2.til","Media\tileset.bmp")
PlayObject kartta,0,0,1

ukko = LoadObject ("Media\guy.bmp",72)

SetupCollision ukko, kartta, 1, 4, 2

//|!!!!!!!!!!!!!!!!!!!!!!!!!!!|
//Välttämättömät kuvamuuttujat
effbuff = MakeImage(SW, SH)
effbuff2 = CloneImage(effbuff)
//|!!!!!!!!!!!!!!!!!!!!!!!!!!!|

Repeat

    If LeftKey() Then TurnObject ukko,5
    If RightKey() Then TurnObject ukko,-5
    If UpKey() Then MoveObject ukko,2
    If DownKey() Then MoveObject ukko,-2

    UpdateGame

    CloneCameraPosition ukko

    DrawGame 
    //Camerax -ja y pois
    If koko > 1 Then Koko = Koko + KeyDown(cbeyW) - KeyDown(cbkeys)
    Amplitudi = Amplitudi + KeyDown(cbkeyd) - KeyDown(cbkeya)
    Kulma = Kulma + KulmaNopeus


    DrawToImage effbuff
        Cls
    DrawToImage effbuff2
        Cls 
    DrawToScreen 
    
    Gosub PÄEVITÄ_EFEEKTI
    
    Color cbblack
    Box 0, 0, SW, SH
    DrawImage effbuff2, 0, 0
    
   Color cbwhite
    Text 0, 0, "FPS: "+FPS()

    DrawScreen True

Forever

PÄEVITÄ_EFEEKTI:
    kulma = kulma + KulmaNopeus
    
    For x# = 0 To SW / Koko
        CopyBox Int(x) * Koko, 0, Koko, SH, Int(x)*Koko, Int(Sin(x+kulma)*Amplitudi), SCREEN(), Image(effbuff)
    Next x#

    For y# = 0 To SH / Koko
        CopyBox 0, Int(y) * Koko, SW, Koko,  Int(Sin(y+kulma)*Amplitudi), Int(y)*koko , Image(effbuff), Image(effbuff2)
    Next y#
Return 

Last edited by MaGetzUb on Sun Apr 03, 2011 8:51 pm, edited 1 time in total.
Solar Eclipse
Meneillä olevat Projektit:
We're in a simulation, and God is trying to debug us.

User avatar
Latexi95
Guru
Posts: 1164
Joined: Sat Sep 20, 2008 5:10 pm
Location: Lempäälä

Re: Efektit

Post by Latexi95 » Sun Apr 03, 2011 8:43 pm

MaGetzUb wrote:Väsäsimpä aikoinaan tällaisen aaltoiluefektin. Olisi kiva tietää teidän FPS:ät. :)

Code: Select all

//effect by: MaGetzUb 2011

Const SW = 640
Const SH = 480
SCREEN SW, SH
SCREEN SW, SH, 32, 2
//|!!!!!!!!!!!!!!!!!!!!!!!!!!!!|
//säätele arvoja!!!
Global Koko
Global Amplitudi 
Global Kulma
Amplitudi = 20
Koko = 1
Kulma = 0
KulmaNopeus = 2
//|!!!!!!!!!!!!!!!!!!!!!!!!!!!!|


kartta = LoadMap("Media\cdm2.til","Media\tileset.bmp")
PlayObject kartta,0,0,1

ukko = LoadObject ("Media\guy.bmp",72)

SetupCollision ukko, kartta, 1, 4, 2

//|!!!!!!!!!!!!!!!!!!!!!!!!!!!|
//Välttämättömät kuvamuuttujat
effbuff = MakeImage(SW, SH)
effbuff2 = CloneImage(effbuff)
//|!!!!!!!!!!!!!!!!!!!!!!!!!!!|

Repeat

    If LeftKey() Then TurnObject ukko,5
    If RightKey() Then TurnObject ukko,-5
    If UpKey() Then MoveObject ukko,2
    If DownKey() Then MoveObject ukko,-2

    UpdateGame

    CloneCameraPosition ukko

    DrawGame 
    //Camerax -ja y pois
    If koko > 1 Then Koko = Koko + KeyDown(cbeyW) - KeyDown(cbkeys)
    Amplitudi = Amplitudi + KeyDown(cbkeyd) - KeyDown(cbkeya)
    Kulma = Kulma + KulmaNopeus


    DrawToImage effbuff
        Cls
    DrawToImage effbuff2
        Cls 
    DrawToScreen 
    
    Gosub PÄEVITÄ_EFEEKTI
    
    Color cbblack
    Box 0, 0, SW, SH
    DrawImage effbuff2, 0, 0
    
    Style = Style Xor KeyHit(s)
    Text 0, 0, "FPS: "+FPS()

    DrawScreen True

Forever

PÄEVITÄ_EFEEKTI:
    kulma = kulma + KulmaNopeus
    
    For x# = 0 To SW / Koko
        CopyBox Int(x) * Koko, 0, Koko, SH, Int(x)*Koko, Int(Sin(x+kulma)*Amplitudi), SCREEN(), Image(effbuff)
    Next x#

    For y# = 0 To SH / Koko
        CopyBox 0, Int(y) * Koko, SW, Koko,  Int(Sin(y+kulma)*Amplitudi), Int(y)*koko , Image(effbuff), Image(effbuff2)
    Next y#
Return 

Tasaisesti 20 pyöri FPS. Oli kyllä upea efekti.

User avatar
MaGetzUb
Guru
Posts: 1715
Joined: Sun Sep 09, 2007 12:35 pm
Location: Alavus

Re: Efektit

Post by MaGetzUb » Sun Apr 03, 2011 8:54 pm

En ymmärrä.. Itselläni pyörii yli puolet nopeammin.
Image
Solar Eclipse
Meneillä olevat Projektit:
We're in a simulation, and God is trying to debug us.

User avatar
MetalRain
Active Member
Posts: 188
Joined: Sun Mar 21, 2010 12:17 pm
Location: Espoo

Re: Efektit

Post by MetalRain » Sun Apr 03, 2011 9:28 pm

Kyllähän tuo ihan tasasesti kuuttakymppiä tuntu menevän vaikka resoluutiotakin nosti 640x480 -> 1920x1200. Näppärä efekti kaikenkaikkiaan, vaikken oikeastaan keksi hyvää käyttötarkoitusta. Veden väreilyyn ehkä?

User avatar
Viltzu
Guru
Posts: 1132
Joined: Sun Aug 26, 2007 5:45 pm
Location: Alavieska
Contact:

Joku random

Post by Viltzu » Sun Apr 03, 2011 9:49 pm

Jotai randomia vaa ja ny nukq.

Code: Select all

Repeat
    Lock
    For x = 0 To 400
        For y = 0 To 300
            PutPixel2 x, y,  e + x * y * 4 
            e = e + 1
        Next y
        
    Next x
    Unlock
    DrawScreen
Forever
EDIT:

MaGetzUbin efekti pyöri tasasesti 60fps


User avatar
buke44
Active Member
Posts: 169
Joined: Sat May 23, 2009 8:10 pm
Location: Tampere

Re: Efektit

Post by buke44 » Sun Apr 03, 2011 10:22 pm

En nyt tiedä onko tämä efekti vai peli mutta postaan tänne kuitenkin. Peli antaa oikean 3d-vaikutelman, kun pelaat silmät ristissä niin, että kohdistat molemmat ruudut päällekkäin. Ohjaa hiirellä ja ammu klikkaamalla. Tavoitteena on ampua lähestyvät raksit. Rivillä 23 voi muuttaa 3d-vaikutelman syvyyttä.

Code: Select all

SCREEN 800,600,0,2
SetWindow "",3
FrameLimit 50

Global ruutu1,ruutu2

isofont=LoadFont ("Arial",28*ScreenWidth ()/800.0)
kfont=LoadFont ("Arial",22*ScreenWidth ()/800.0)
normifont=LoadFont ("Arial",12*ScreenWidth ()/800.0)

Dot 1,1
Lock 
pix=GetPixel2 (1,1)
Unlock 
ruutu1=MakeImage (ScreenWidth ()/2,ScreenHeight ()/2)
ruutu2=MakeImage (ScreenWidth ()/2,ScreenHeight ()/2)

vaihe=1

'NÄITÄ VOIT MUUTTAA
Global OFFSET3D, KONTROLLIT
kontrollit=2 ' 1: nuolinäppäimet ohjaus ja välilyönti ampuu vasenta alttia pohjassa pitämällä liikkuu 2 kertaa nopeammin 2:hiirellä liikkuminen ja ampuminen
offset3d=10 'jakaja, jolla jaetaan syvyyskakkaa. mitä pienempi, sitä kauempana kohteet ovat toisistaan syvyyssuunnassa.  vaikutelma on aidompi, jos tämä on pieni, mutta se tekee pelaamisesta hankalaa
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


Type al
    Field k
    Field x#
    Field y#
    Field z#
    Field zv#
    Field osuma
    Field ks
EndType 
Type bl
    Field x#
    Field y#
    Field z#
    Field xv#
    Field yv#
EndType 
Type sl
    Field x#
    Field y#
    Field z#
    Field xv#
    Field yv#
    Field zv#
    Field r
    Field b
    Field g
    Field ea
    Field timf
    Field al
EndType 
Type tl
    Field x#
    Field y#
    Field z#
EndType 
Type el
    Field x#
    Field y#
    Field z#
EndType 

alku=Timer ()

tiheys=2000-400*(kontrollit-1)
elamat=5
Wait 500
        al1.al=New (al)
        al1\k=Rand (-40,40)
        al1\x=Rnd (-15,15)
        al1\y=Rnd (-15,15)
        al1\z=Rnd (1.5,2.5)
        al1\zv=Rnd (80,100)
        lastgen=Timer ()+Rand (-tiheys/2,tiheys/2)
sarjatuliuptade=-1
Repeat
    Color cbWhite
    If alkanut Then 
        Select kontrollit 
            Case 1
                px#=px#-KeyDown (205)/2.0*(KeyDown (56)+1)
                px#=px#+KeyDown (203)/2.0*(KeyDown (56)+1)
                py#=py#-KeyDown (208)/2.0*(KeyDown (56)+1)
                py#=py#+KeyDown (200)/2.0*(KeyDown (56)+1)
                If ase=0 And KeyHit (57) And Timer ()-reload>200 Then 
                    bl1.bl=New (bl)
                    bl1\x=-px
                    bl1\y=-py
                    bl1\z=200
                    reload=Timer ()
                EndIf 
                If ase=1 And KeyDown (57) And Timer ()-reload>100 Then 
                    bl1.bl=New (bl)
                    bl1\x=-px
                    bl1\y=-py
                    bl1\z=200
                    reload=Timer ()
                EndIf 
                If ase=2 And KeyDown (57) And Timer ()-reload>25
                    bl1.bl=New (bl)
                    Select asekulma
                        Case 0
                            bl1\x=-px
                            bl1\y=-py
                        Case 1
                             bl1\x=-px+1
                             bl1\y=-py+1
                        Case 2
                            bl1\x=-px+1
                            bl1\y=-py-1
                        Case 3
                             bl1\x=-px-1
                             bl1\y=-py+1      
                        Case 4
                             bl1\x=-px-1
                             bl1\y=-py-1   
                    EndSelect 
                    bl1\z=200
                    asekulma+1
                    If asekulma>4 Then asekulma=0
                    reload=Timer ()  
                EndIf 
                If tiheys<1600 Then 
                    ase=1
                    If sarjatuliuptade=-1 Then sarjatuliuptade=Timer ()
                EndIf 
                If tiheys<1100 Then ase=2
            Case 2
                ShowMouse OFF 
                px#=px-MouseMoveX ()/10.0
                py#=py-MouseMoveY ()/10.0
                If ase=0 And MouseHit (1) And Timer ()-reload>200 Then 
                    bl1.bl=New (bl)
                    bl1\x=-px
                    bl1\y=-py
                    bl1\z=200
                    reload=Timer ()
                EndIf 
                If ase=1 And MouseDown (1) And Timer ()-reload>100 Then 
                    bl1.bl=New (bl)
                    bl1\x=-px
                    bl1\y=-py
                    bl1\z=200
                    reload=Timer ()
                EndIf 
                If ase=2 And MouseDown (1) And Timer ()-reload>25
                    bl1.bl=New (bl)
                    Select asekulma
                        Case 0
                            bl1\x=-px
                            bl1\y=-py
                        Case 1
                             bl1\x=-px+1
                             bl1\y=-py+1
                        Case 2
                            bl1\x=-px+1
                            bl1\y=-py-1
                        Case 3
                             bl1\x=-px-1
                             bl1\y=-py+1     
                        Case 4
                             bl1\x=-px-1
                             bl1\y=-py-1 
                    EndSelect 
                    bl1\z=200
                    asekulma+1
                    If asekulma>4 Then asekulma=0
                    reload=Timer ()
                EndIf 
                PositionMouse 400,300
                asdf=MouseMoveX ()
                asdf=MouseMoveY ()
                If tiheys<900 Then 
                    ase=1
                    If sarjatuliuptade=-1 Then sarjatuliuptade=Timer ()
                EndIf 
                If tiheys<550 Then ase=2
        EndSelect 
    EndIf 
    If px>20 Then px=20
    If px<-20 Then px=-20
    If py>20 Then py=20
    If py<-20 Then py=-20
    For tl1.tl=Each tl
        tl1\z=tl1\z+(tl1\z^1.1)/40
        If ScreenWidth ()/2+tl1\z*(tl1\x)>ScreenWidth ()-1 Or ScreenWidth ()/2+tl1\z*(tl1\x)<1 Or ScreenHeight ()/2+tl1\z*(tl1\y)>ScreenHeight ()-1 Or ScreenHeight ()/2+tl1\z*(tl1\y)<1 Then 
            Delete tl1
        Else 
            d3PutPixel2 (RoundDown ((ScreenWidth ()/2+((tl1\z*tl1\x)/800.0*ScreenWidth ()))/2),RoundDown ((ScreenHeight ()/2+(tl1\z*tl1\y)/600.0*ScreenHeight ())/2),pix,tl1\z/800.0*ScreenWidth ())
       EndIf 
    Next tl1
    For bl1.bl=Each bl
        Color 0,255,255
        d3Circle ((ScreenWidth ()/2+ScreenWidth ()/800.0*bl1\z*(bl1\x+px))/2,(ScreenHeight ()/2+ScreenHeight ()/600.0*bl1\z*(bl1\y+py))/2,RoundUp (bl1\z/10),bl1\z*ScreenWidth ()/800.0)
        bl1\z=bl1\z-(bl1\z^1.1)/10
        bl1\x=bl1\x+bl1\xv
        bl1\y=bl1\y+bl1\yv
        If bl1\z<1 Then Delete bl1
    Next bl1
    For al1.al=Each al
        If al1\osuma=0 Then 
            al1\z=al1\z+(al1\z^1.1)/al1\zv 
        Else 
            al1\y=al1\y+0.1
            al1\k=al1\k+al1\ks*5
            al1\z=al1\z+(al1\z^1.1)/(60+(Timer ()-al1\osuma)/10)
            If Rand (1,2)=2 Then 
                sl1.sl=New (sl)
                sl1\x=al1\x+Cos (al1\k+30)
                sl1\y=al1\y+Sin (al1\k+30)
                sl1\z=al1\z
                sl1\xv=Rnd (-0.5,0.5)
                sl1\yv=Rnd (-1,0)
                sl1\zv=Rnd (0,0.2)
                puna=Rand (0,255)
                sl1\r=255
                sl1\b=puna
                sl1\g=0
                sl1\ea=Rand (75,100)
                sl1\al=1
                sl1\timf=Timer ()
            EndIf 
            If Timer ()-al1\osuma>500 Then 
                For i=1 To 20
                    sl1.sl=New (sl)
                    sl1\x=al1\x+Cos (al1\k+30)
                    sl1\y=al1\y+Sin (al1\k+30)
                    sl1\z=al1\z
                    sl1\xv=Rnd (-2,2)
                    sl1\yv=Rnd (-2,2)
                    sl1\zv=Rnd (0,2)
                    puna=Rand (0,255)
                    sl1\r=255
                    sl1\b=puna
                    sl1\g=0
                    sl1\ea=Rand (300,500)
                    sl1\timf=Timer ()                
                Next i
                Delete al1
            EndIf 
        EndIf 
        Color cbWhite
        d3Line ((ScreenWidth ()/2+(al1\z*(al1\x+px)-Cos (al1\k-30)*al1\z)*ScreenWidth ()/800.0 )/2,(ScreenHeight ()/2+(al1\z*(al1\y+py)-Sin (al1\k-30)*al1\z)*ScreenHeight ()/600.0)/2,(ScreenWidth ()/2+(al1\z*(al1\x+px)+Cos (al1\k-30)*al1\z)*ScreenWidth ()/800.0)/2,(ScreenHeight ()/2+(al1\z*(al1\y+py)+Sin (al1\k-30)*al1\z)*ScreenHeight ()/600.0)/2,al1\z*ScreenWidth ()/800.0 )
        d3Line ((ScreenWidth ()/2+(al1\z*(al1\x+px)-Cos (al1\k+30)*al1\z)*ScreenWidth ()/800.0 )/2,(ScreenHeight ()/2+(al1\z*(al1\y+py)-Sin (al1\k+30)*al1\z)*ScreenHeight ()/600.0)/2,(ScreenWidth ()/2+(al1\z*(al1\x+px)+Cos (al1\k+30)*al1\z)*ScreenWidth ()/800.0)/2,(ScreenHeight ()/2+(al1\z*(al1\y+py)+Sin (al1\k+30)*al1\z)*ScreenHeight ()/600.0)/2,al1\z*ScreenWidth ()/800.0 )
        poistettu=0
        For bl1.bl=Each bl
            If bl1\x>(al1\x-2*al1\z/30) And bl1\x<(al1\x+2*al1\z/30) And bl1\y>(al1\y-2*al1\z/30) And bl1\y<(al1\y+2*al1\z/30) And bl1\z>al1\z-8 And bl1\z<al1\z+1 And al1\osuma=0 Then 
                al1\osuma=Timer ()
                Repeat 
                    al1\ks=Rand (-1,1)
                Until al1\ks
                If tiheys>200 Then tiheys=tiheys-(tiheys+800)/200
                Delete bl1
            EndIf 
        Next bl1
        If al1\z>180 And al1\osuma=0 Then 
            Delete al1
            elamat-1
            ClsColor cbRed
            Cls 
            ClsColor cbBlack
        EndIf 
        d3text (50,100,al1\z,30)
    Next al1
    For el1.el=Each el
        el1\z=el1\z+(el1\z^1.1)/70
        Color cbRed
        d3Box ((ScreenWidth ()/2+(el1\z*(el1\x+px)-RoundUp (el1\z/5))*ScreenWidth ()/800.0)/2,(ScreenHeight ()/2+(el1\z*(el1\y+py))*ScreenHeight ()/600.0)/2,RoundUp (el1\z/10*ScreenWidth ()/800.0)*3,RoundUp (el1\z/10*ScreenWidth ()/800.0 ),el1\z*ScreenWidth ()/800.0)
        d3Box ((ScreenWidth ()/2+(el1\z*(el1\x+px))*ScreenWidth ()/800.0)/2,(ScreenHeight ()/2+(el1\z*(el1\y+py)-RoundUp (el1\z/5))*ScreenHeight ()/600.0)/2,RoundUp (el1\z/10*ScreenWidth ()/800.0),RoundUp (el1\z/10*ScreenWidth ()/800.0)*3,el1\z*ScreenWidth ()/800.0)
        For bl1.bl=Each bl
            If el1\x>bl1\x-2 And el1\x<bl1\x+2 And el1\y>bl1\y-2 And el1\y<bl1\y+2 And bl1\z<el1\z+1 And bl1\z>el1\z-8 Then 
                elamat+1
                Delete el1
            EndIf 
        Next bl1
        If el1\z>225 Then Delete el1
    Next el1
    Randomize Int (Right (Str (Timer ()), 4))
    If Timer ()-lastgen>tiheys Then 
        al1.al=New (al)
        al1\k=Rand (-40,40)
        al1\x=Rnd (-15,15)
        al1\y=Rnd (-15,15)
        al1\z=Rnd (1.5,2.5)
        al1\zv=Rnd (80,100)
        lastgen=Timer ()+Rand (-tiheys/2,tiheys/2)
    EndIf 

    For sl1.sl=Each sl
        sl1\x=sl1\x+sl1\xv
        sl1\y=sl1\y+sl1\yv
        sl1\z=sl1\z+sl1\zv
        If sl1\al Then sl1\yv=sl1\yv+Rnd (0,0.2)
        Color sl1\r,sl1\b,sl1\g
        d3Circle ((400+sl1\z*(sl1\x+px))/2,(300+sl1\z*(sl1\y+py))/2,RoundUp (sl1\z/30),sl1\z)
        If Timer ()-sl1\timf>sl1\ea Then Delete sl1
    Next sl1
    For i=1 To 2
        tl1.tl=New (tl)
        Repeat 
            tl1\x=Rand (-100,100)
        Until tl1\x>20 Or tl1\x<-20
        Repeat 
            tl1\y=Rand (-100,100)
        Until tl1\y>20 Or tl1\y<-20
        tl1\z=3
    Next i
    If Rand (1,300)=1 Then 
        el1.el=New (el)
        el1\x=Rnd (-15,15)
        el1\y=Rnd (-15,15)
        el1\z=Rnd (1.5,2.5)
    EndIf 
    Color cbWhite
    SetFont normifont 
    d3Text (50,1,tiheys,30)
    d3Text (50,20,FPS (),30)
    d3Text (50,40, Timer ()-alku,30)
    d3Text (200,1, elamat,30)
    d3Text (50,80, px+" "+py,30)
    Color cbBlue
    d3Line (370/2*ScreenWidth ()/800.0,300/2*ScreenHeight ()/600.0,430/2*ScreenWidth ()/800.0,300/2*ScreenHeight ()/600.0,30)
    d3Line (400/2*ScreenWidth ()/800.0,270/2*ScreenHeight ()/600.0,400/2*ScreenWidth ()/800.0,330/2*ScreenHeight ()/600.0,30)
    d3Circle (380/2*ScreenWidth ()/800.0,280/2*ScreenHeight ()/600.0,40/2*ScreenWidth ()/800.0,30,0)
    If Not alkanut Then 
        SetFont kfont 
        d3Text (50,50,"Paina näppäintä kun olet kohdistanut",30) 
    EndIf 
    If sarjatuliuptade>0 Then 
        SetFont isofont
        d3Text (50,50,"Sait sarjatuliaseen",30) 
        SetFont normifont
    EndIf 
    If Timer ()-sarjatuliuptade>750 And sarjatuliuptade>0 Then sarjatuliuptade=0
    draw3d ()
    DrawScreen 
    If Not alkanut Then WaitKey
    alkanut=1
Forever  

Function d3line (x,y,x2,y2,z#)
    DrawToImage ruutu1
    Line x-z/offset3d,y,x2-z/offset3d,y2
    DrawToImage ruutu2
    Line x+z/offset3d,y,x2+z/offset3d,y2
    DrawToScreen 
EndFunction 

Function d3text (x,y,s$,z#)
    DrawToImage ruutu1
    Text x-z/offset3d,-y,s
    DrawToImage ruutu2
    Text x+z/offset3d,-y,s
    DrawToScreen 
EndFunction 

Function d3circle (x,y,c,z#,k=1)
    DrawToImage ruutu1
    Circle x-z/offset3d,y,c,k
    DrawToImage ruutu2
    Circle  x+z/offset3d,y,c,k
    DrawToScreen 
EndFunction 

Function d3putpixel2 (x,y,p,z)
    Lock 
        DrawToImage ruutu1
        PutPixel x-z/offset3d,y,p
        DrawToImage ruutu2
        PutPixel  x+z/offset3d,y,p
        DrawToScreen 
    Unlock 
EndFunction 

Function d3box (x,y,w,h,z)
    DrawToImage ruutu1
    Box x-z/offset3d,y,w,h
    DrawToImage ruutu2
    Box  x+z/offset3d,y,w,h
    DrawToScreen 
EndFunction 

Function draw3d ()
    DrawImage ruutu1,0,ScreenHeight ()/4
    DrawImage ruutu2,ScreenWidth ()/2,ScreenHeight ()/4
    DeleteImage ruutu1
    DeleteImage ruutu2
    ruutu1=MakeImage (ScreenWidth ()/2,ScreenHeight ()/2)
    ruutu2=MakeImage (ScreenWidth ()/2,ScreenHeight ()/2)    
EndFunction 

User avatar
MaGetzUb
Guru
Posts: 1715
Joined: Sun Sep 09, 2007 12:35 pm
Location: Alavus

Re: Efektit

Post by MaGetzUb » Sun Apr 03, 2011 11:13 pm

Melko hankala saada tuo 3D vaikutelma toimimaan. :/
Miksi muuten ruudut tuhotaan tuossa Draw3d funktiossa? :?
Solar Eclipse
Meneillä olevat Projektit:
We're in a simulation, and God is trying to debug us.

Post Reply