Graphics3D 800,600,32,2

; Deklarationen
Dim GradientR%(0),GradientG%(0),GradientB%(0),Prozent%(0),Rot%(0),Gruen%(0),Blau%(0)
Dim images%(9)
Dim Array%(0)
Global maxx%=512
Global maxy%=256
Global max%=maxx*maxy
Global pixelstep%=512

; alles total zufällig
SeedRnd MilliSecs()

; Farbverlauf erstellen
Restore ClassMT : CreateGradient(9,255)

; Quellbilder einlesen
: For i%=0 To 9 : images(i)=LoadImage("512/planet"+i+".jpg") : Next

; Zufallsarray erstellen
CreateRandomArray(max)

; Zieltextur erstellen
output=CreateTexture(maxx,maxy,16+32)
buff5=TextureBuffer(output)
survey=CreateImage(maxx,maxy)
width=ImageWidth(survey)
buff6=ImageBuffer(survey)

; Grundfarbe der Textur festlegen
SetBuffer buff5
Color 17, 82,112
Rect 0,0,maxx,maxy,1
Color 255,255,255
SetBuffer BackBuffer()

; Planet
planet=CreateSphere(32)
ScaleEntity planet,10,10,10
PositionEntity planet,0,0,1000
EntityFX planet,2
EntityTexture planet,output,0,1
TextureBlend output,2
EntityShininess planet,0.25

; Wolkentextur
Clouds=CreateSphere(32,planet)
ctex=LoadTexture("clouds.png",2)
EntityTexture Clouds,ctex,0,1
ScaleTexture ctex,0.5,1
RotateTexture ctex,90
TextureBlend ctex,2
EntityBlend clouds,1
EntityOrder clouds,-1

; Licht
light=CreateLight(1)
AmbientLight 8,8,8

; Kamera
camera=CreateCamera()
PositionEntity camera,20,0,0
CameraRange camera,0.1,1000

; Maus in die Mitte, Kamera zielt auf Planet
MoveMouse GraphicsWidth()/2,GraphicsHeight()/2
HidePointer()
PointEntity camera,planet

; anfangs keine Welt erstellen
newworld=False

; Zeit messen
time=MilliSecs()

; Hauptschleife
While Not KeyHit(1)
   
   ; FPS messung
    FPS_C=FPS_C+1 : If fms<MilliSecs() Then fms=MilliSecs()+1000 : FPS=FPS_C : FPS_C=0
   
   ; Frame tweening
   Tween#=Float(MilliSecs()-FrameTime)/10.0 : FrameTime=MilliSecs()
   
   ; einfache Steuerung
   mxs#=MouseXSpeed()
   mys#=MouseYSpeed()
   ;RotateEntity camera,EntityPitch(camera)+(mys#/5),EntityYaw(camera)-(mxs#/5),0
   If KeyDown(200) Then MoveEntity camera,0,0, 1*Tween
   If KeyDown(208) Then MoveEntity camera,0,0,-1*Tween
   
   ; aktuelle Zeit messen
   ms=MilliSecs()
   
   ; SPACE und Newworld-Flag False? dann neue Karte erstellen
   If KeyHit(57) Then
      
      ; Startzeit messen
      starttime=ms
      
      ; Pixelcounter rücksetzen
      i=0
      water%=0
      land%=0
      
      ; vier Planeten als Basis wählen
      map$=ZERO(Rand(0,9999),4)
      
      ; Planetencodes extrahieren
      i1=Int(Left(map,1))
      i2=Int(Mid(map,1,1))
      i2=Int(Mid(map,2,1))
      i4=Int(Right(map,1))
      
      ; neue Bildpuffer setzen
      buff1=ImageBuffer(images(i1))
      buff2=ImageBuffer(images(i2))
      buff3=ImageBuffer(images(i3))
      buff4=ImageBuffer(images(i4))
      
      ; Newworld-Flag auf True setzen
      newworld=True
      
   EndIf
   
   ; LMB = Kamerazoom erhöhen, um die Veränderung zu sehen
   If MouseDown(1) Then CameraZoom camera,50 Else CameraZoom camera,1
   
   ; Planet und Wolken ein wenig drehen
   TurnEntity planet,0,-0.1*Tween,0
   
   ; SPACE gedrückt, 30ms vergangen und Berechnungsflag wahr? Dann weiter
   If ms>time And newworld Then
      
      roundstart=ms
      
      ; Vergleichszeit = aktuelle Zeit + 60ms
      time=ms+30
      
      ; Anzahl Pixel pro Durchgang berechnen
      adder%=(pixelstep/Tween)
      
      ; Start/Ende für aktuellen Schleifendurchlauf setzen
      start=i
      ende=i+adder
      
      ; Ende grösser als Pixelanzahl? Dann Ende=Pixelanzahl
      If ende>max-1 Then ende=max-1
      
      ; Puffer sperren
      LockBuffer buff1
      LockBuffer buff2
      LockBuffer buff3
      LockBuffer buff4
      LockBuffer buff5
      LockBuffer buff6
      
      ; aktueller Schleifendurchlauf
      For j=start To ende
         
         ; Pixelinkrement
         i=i+1
         
         ; Pixel grösser als Pixelanzahl? Ende
         If i>max-1 Then
            newworld=False
            Goto skip
         EndIf
            
         ; X/Y-Position des Pixels aus dem Zufallsarray berechnen
         y=Int(Array(i)/maxx)
         x=Array(i)-(y*maxx)
         
         ; Quellfarben einlesen
         rgb1=ReadPixelFast(x,y,buff1)
         rgb2=ReadPixelFast(x,y,buff2)
         rgb3=ReadPixelFast(x,y,buff3)
         rgb4=ReadPixelFast(x,y,buff4)
         
         ; aufsplitten
         r1=255-(rgb1 And $ff0000)/$10000
         r2=(rgb2 And $ff0000)/$10000
         r3=255-(rgb3 And $ff0000)/$10000
         r4=(rgb4 And $ff0000)/$10000
         
         ; mit Filter mischen
         r=Average(r1,r2)
         r=Lighten(r,r3)
         r=HardLight(r,r4)
         
         ; Legende brauchbarer Filterkombinationen:
         ;
         ; S = Softlight
         ; M = Multiply
         ; L = Lighten
         ; A = Average
         ; H = Hardlight
         ; O = Overlay
         ; E = exclusion
         ; D = Difference
         ; N = Negation
         ;
         ; SSM = um 99% Land
         ; SSS = 25-75% Land
         ; SSL = 75-25% Land, flacher
         ; ALH = 35-65% Land, kontinental
         ; AMM =   100% Land, gebirgig
         ; OLS = 25-75% Land
         ; OLC =   <10% Land, ozeanisch
         ; MMM =   100% Land, verschneites Gebirge
         ; EDN = verschieden, erdähnlich, Archipelagos
         ; MNS = verschieden, erdännlich, Archipelagos
         
         ; über 128: unter Wasser, sonst Land
         If r>=128 Then water=water+1 Else land=land+1
         
         ; Zielfarbe aus Farbverlauf bestimmen
         rgb5=GradientR(r)*$10000+GradientG(r)*$100+GradientB(r)
         
         ; in Textur schreiben
         WritePixelFast x,y,rgb5,buff5
         WritePixelFast x,y,rgb5,buff6
         
      Next
      
      .skip
      
      endtime=MilliSecs()
      
      ; Puffer entsperren
      UnlockBuffer buff6
      UnlockBuffer buff5
      UnlockBuffer buff4
      UnlockBuffer buff3
      UnlockBuffer buff2
      UnlockBuffer buff1
      
      ; verbrauchte Millisekunden pro Durchgang berechnen
      midtime=(midtime+(endtime-roundstart))/2.0
      
   EndIf
   
   RenderWorld
   
   ; Ausgabe
   Text 0,  0,"Planet Source Maps: "+map
   Text 0, 15,"Pixels blended....: "+(i*100)/max+"%"
   Text 0, 30,"Transition Time...: "+(endtime-starttime)+"ms"
   Text 0, 45,"Used ms per cycle.: "+midtime+"ms"
   Text 0, 60,"Pixels per cycle..: "+adder
   Text 0, 75,"Water coverage....: "+(water*100.0)/max+"%"
   Text 0, 90,"Land coverage.....: "+(land*100.0)/max+"%"
   Text 0,105,"FPS...............: "+FPS
   Text 0,120,"Tris rendered.....: "+TrisRendered()
   
   DrawImage survey,GraphicsWidth()-width,0
   
   Flip 0
   
Wend

End

; Soft Light Filter
Function SoftLight(a%,b%)
   Local c%
   c=a*b Shr 8
   Return (c+a*(255-((255-a)*(255-b) Shr 8)-c) Shr 8)
End Function

; Hard Light Filter
Function HardLight(a%,b%)
   If b<128 Then Return (a*b) Shr 7 Else Return 255-((255-b)*(255-a) Shr 7)
End Function

; Differenz Filter
Function Difference(a%,b%)
   Return Abs(a-b)
End Function

; Multiply Filter
Function Multiply(a%,b%)
   Return (a*b) Shr 8
End Function

; Durchschnittsfilter
Function Average(a%,b%)
   Return (a+b) Shr 1
End Function

; Screenfilter
Function Screen(a%,b%)
   Return 255-((255-a)*(255-b) Shr 8)
End Function

; Aufhellfilter
Function Lighten(a%,b%)
   If a>b Then Return a Else Return b
End Function

; Abdunkelfilter
Function Darken(a%,b%)
   If a<b Then Return a Else Return b
End Function

; Negativfilter
Function Negation(a%,b%)
   Return 255-Abs(255-a-b)
End Function

; Ausschlussfilter
Function Exclusion(a%,b%)
   Return a+b-(a*b Shr 7)
End Function

; Overlayfilter
Function Overlay(a%,b%)
   If a<128 Then Return (a*b) Shr 7 Else Return 255-((255-a)*(255-b) Shr 7)
End Function

; Farbbrandfilter
Function ColorDodge(a%,b%)
   If b=255 Then
      Return 255
   Else
      Local c%=Floor((a Shl 8)/(255-b))
      If c>255 Then Return 255 Else Return c
   EndIf
End Function

; Farbverlauf erstellen
Function CreateGradient(colors%,steps%)
   
   Dim GradientR%(steps),GradientG%(steps),GradientB%(steps),Prozent%(colors),Rot%(colors),Gruen%(colors),Blau%(colors)
   
   Local i%,pos1%,pos2%,pdiff%
   Local rdiff%,gdiff%,bdiff%
   Local rstep#,gstep#,bstep#
   Local counter%=1
   
   ; Farbcodes einlesen
   For i=1 To colors : Read Prozent(i),Rot(i),Gruen(i),Blau(i) : Next
   
   ; Gradient berechnen
   While counter<colors
      
      ; Prozent in Step-Position umrechnen
      pos1=Prozent(counter)*steps/100
      pos2=Prozent(counter+1)*steps/100
      
      ; Abstand berechnen
      pdiff=pos2-pos1
      
      ; Differenz zwischen den Farben berechnen
      rdiff%=Rot(counter)-Rot(counter+1)
      gdiff%=Gruen(counter)-Gruen(counter+1)
      bdiff%=Blau(counter)-Blau(counter+1)
      
      ; Schrittweite zwischen den Farben berechnen
      rstep#=rdiff*1.0/pdiff
      gstep#=gdiff*1.0/pdiff
      bstep#=bdiff*1.0/pdiff
      
      ; Zwischenfarbcodes berechnen
      For i=0 To pdiff
         
         GradientR(pos1+i)=Int(Rot(counter)-(rstep*i))
         GradientG(pos1+i)=Int(Gruen(counter)-(gstep*i))
         GradientB(pos1+i)=Int(Blau(counter)-(bstep*i))
         
      Next
      
      ; Zähler erhöhen
      counter=counter+1
      
   Wend
   
End Function

; Zufallsarray erstellen. Es werden alle Werte zufällig durcheinandergewürfelt, so dass jeder Wert nur 1x vorkommt
Function CreateRandomArray(size%)
   
   ; Array neu dimensionieren
   Dim Array(size)
   
   ; Array mit allen Zahlen von 1...size füllen
   For i = 0 To size-1 : Array(i) = i : Next
   
   ; Würfeln
   For N% = 0 To size-2
      
      M% = Rand( N%, size - 1)
      Z% = Array(N%)
      
      Array(N%) = Array(M%)
      Array(M%) = Z%
      
   Next
   
End Function

; Zahl mit immer gleicher Anzahl an Stellen rückgeben, mit vorangestellen Nullen
Function ZERO$(number%,lenght%=2)
   
   Local r$=""
   
   For i=1 To lenght-Len(Str(number))
      
      r$=r$+"0"
      
   Next
   
   Return r$+Str(number)
   
End Function

; Farbverlaufcodes für einen Klasse-M-Planeten
.ClassMT
Data   0,255,255,255
Data   5,179,179,179
Data  10,153,143, 92
Data  25,115,128, 77
Data  48, 42,102, 41
Data  50, 69,108,118
Data  52, 17, 82,112
Data  75,  9, 62, 92
Data 100,  2, 43, 68

sizex%=512
sizey%=256
gfx$="planet0.jpg"

Graphics sizex,sizey*2,32,2

bank=LoadImageBank(gfx$)
;SaveBankImage(bank,"test.img")
;bank=LoadBankImage("test.img",sizex,sizey)

vergleich=LoadImage(gfx$)

While Not KeyHit(1)
   
   ms1=MilliSecs()
   DrawImageBank bank,sizex,sizey
   zeit1=MilliSecs()-ms1
   
   ms2=MilliSecs()
   DrawVergleichImage(vergleich,sizey)
   zeit2=MilliSecs()-ms2
   
   Text 0,0,"Bank: "+zeit1+"ms"
   Text 0,sizey,"Readpixelfast: "+zeit2+"ms"
   
   Flip
   
Wend

End

Function LoadImageBank(filename$)
   
   Local x%,y%,rgb%,h%,offset%
   
   Local image%=LoadImage(filename$)
   Local width%=ImageWidth(image)
   Local height%=ImageHeight(image)
   
   Local bank%=CreateBank(width*height)
   
   Local buffer%=ImageBuffer(image)
   
   LockBuffer buffer
   
   For x=0 To width-1
      
      For y=0 To height-1
         
         rgb=ReadPixelFast(x,y,buffer)
         h=(rgb And $ff0000)/$10000
         
         offset=(y*width)+x
         PokeByte bank,offset,h
         
      Next
      
   Next
   
   UnlockBuffer buffer
   
   FreeImage image
   
   Return bank
   
End Function

Function SaveBankImage(bank%,filename$)
   
   Local f%=WriteFile(filename$)
   
   WriteBytes (bank,f,0,BankSize(bank))
   
   CloseFile f
   
End Function

Function LoadBankImage(filename$,width%,height%)
   
   Local f%=OpenFile(filename$)
   
   Local bank%=CreateBank(width*height)
   
   ReadBytes(bank,f,0,BankSize(bank))
   
   CloseFile f
   
   Return bank
   
End Function

Function DrawImageBank(bank%,width%,height%)
   
   Local x%,y%,h%,offset%,rgb%
   
   Local buffer%=FrontBuffer()
   
   LockBuffer buffer
   
   For x=0 To width-1
      
      For y=0 To height-1
         
         offset=(y*width)+x
         h=PeekByte(bank,offset)
         
         rgb=h*$10000+h*$100+h
         WritePixel x,y,rgb,buffer
         
      Next
      
   Next
   
   UnlockBuffer buffer
   
End Function

Function DrawVergleichImage(image,offsety)
   
   Local x%,y%,rgb%,h%
   
   Local width%=ImageWidth(image)
   Local height%=ImageHeight(image)
   
   Local buffer1%=FrontBuffer
   Local buffer2%=ImageBuffer(image)
   
   LockBuffer buffer1
   LockBuffer buffer2
   
   For x=0 To width-1
      
      For y=0 To height-1
         
         rgb=ReadPixelFast(x,y,buffer2)
         h=(rgb And $ff0000)/$10000
         
         rgb=h*$10000+h*$100+h
         WritePixelFast x,y+offsety,rgb,buffer1
         
      Next
      
   Next
   
   UnlockBuffer buffer2
   UnlockBuffer buffer1
   
End Function

Graphics 1024,512,32,2
Dim GPTexturen(0),GPGradient(256),GPRandMap(0)
Global GPTexSizeX,GPTexSizeY
Global GPMapNumber,GPlanetCount
Global TImg=CreateImage(1024,512)
Timer=CreateTimer(60)


InitPlanetGenerator()
UpdPlanetTextur()


SetBuffer BackBuffer()
Repeat

   If KeyHit(57)=1 Then
      GPMapNumber=MilliSecs():GPlanetCount=0
   End If

   If GPlanetCount>-1 Then UpdPlanetTextur(10)


   DrawBlock TImg,0,0


Flip 0:WaitTimer(Timer)
Until KeyDown(1)=1
End







Function UpdPlanetTextur(MaxMS=1000)



   Zeit=MilliSecs()
   Tween=MilliSecs()+MaxMS
   MNumber$=Right("0000"+GPMapNumber,4)

   
   TexSize=(GPTexSizeX*GPTexSizeY)
   PTDataOfset0=(Asc(Mid(MNumber,1,1))-48)*TexSize
   PTDataOfset1=(Asc(Mid(MNumber,2,1))-48)*TexSize
   PTDataOfset2=(Asc(Mid(MNumber,3,1))-48)*TexSize
   PTDataOfset3=(Asc(Mid(MNumber,4,1))-48)*TexSize
   

   IBuff=ImageBuffer(TImg):LockBuffer IBuff
   Repeat:Pos=GPRandMap(GPlanetCount)
   
      X=Int(Pos/GPTexSizeY):Y=Pos-X*GPTexSizeY
     
      R1=GPTexturen(PTDataOfset0+Pos)
      R2=255-GPTexturen(PTDataOfset1+Pos)
      R3=GPTexturen(PTDataOfset2+Pos)
      R4=255-GPTexturen(PTDataOfset3+Pos)     
 

      r=Average(r1,r2)
      r=Lighten(r,r3)
      r=HardLight(r,r4)
     
      GPlanetCount=GPlanetCount+1:Count=Count+1
      WritePixelFast(X,Y,GPGradient(R),IBuff)
      If GPlanetCount=TexSize Then GPlanetCount=-1 Exit
      If Count>65536 Then Count=0:If MilliSecs()>Tween Then Exit
     
   Forever:UnlockBuffer IBuff
   If MaxMS=1000 Then AppTitle (MilliSecs()-Zeit)
End Function


Function HardLight(a%,b%)
   If b<128 Then Return (a*b) Shr 7 Else Return 255-((255-b)*(255-a) Shr 7)
End Function

Function Average(a%,b%)
   Return (a+b) Shr 1
End Function

Function Lighten(a%,b%)
   If a>b Then Return a Else Return b
End Function

Function InitPlanetGenerator()
   CreateGradient()

   For TexCount=0 To 9:TexName$="1024\Planet"+TexCount+".jpg"
      Image=LoadImage(TexName):GPTexSizeX=ImageWidth(Image)
      GPTexSizeY=ImageHeight(Image):IBuff=ImageBuffer(Image)

      If TexCount=0 Then TexSize=GPTexSizeX*GPTexSizeY
      If TexCount=0 Then Dim GPTexturen(TexSize*10)
     

      LockBuffer IBuff:Count=TexCount*TexSize
      For X=0 To GPTexSizeX-1:For Y=0 To GPTexSizeY-1
         RGB=(ReadPixelFast(X,Y,IBuff) Shl 8) Shr 24
         GPTexturen(Count)=RGB:Count=Count+1
      Next:Next:UnlockBuffer IBuff:FreeImage Image
   Next:TexSize=TexSize-1
   
 
   Dim GPRandMap(TexSize+1)
   For I=0 To TexSize:GPRandMap(i)=i:Next
 

   ;Return
   

   
   For N=0 To TexSize
      M=Rand(N,TexSize-2):Z=GPRandMap(N)
      GPRandMap(N)=GPRandMap(M)
      GPRandMap(M)=Z
   Next

   
End Function






Function CreateGradient()

   Repeat:LevA=LevB
      RedA=RedB:GreenA=GreenB:BlueA=BlueB

      Read LevB,RedB,GreenB,BlueB
      M#=(LevB-LevA):C=0:R#=(RedB-RedA)/M
      G#=(GreenB-GreenA)/M:B#=(BlueB-BlueA)/M

      For I=LevA To LevB
         RR=R*C+RedA GG=G*C+GreenA BB=B*C+BlueA               
         GPGradient(I)=RR*65536+GG*256+BB:C=C+1
      Next
   Until LevB=255   
End Function

Data   0,255,255,255
Data  12,179,179,179
Data  25,153,143, 92
Data  64,115,128, 77
Data 122, 42,102, 41
Data 128, 69,108,118
Data 133, 17, 82,112
Data 191,  9, 62, 92
Data 255,  2, 43, 68