You are not logged in or registered. Please login or register to use the full functionality of this board...
SIGN IN Join Our Community For FREE


Voxel Landscape
05-22-2017, 03:45 PM
Post: #1
 (Print Post)
Voxel Landscape
This is an ABC packet (QB45) converted to BlitzPlus.

In this conversion I've expanded the color options and allowed multiple screen sizes.

Code Snippet: [Select]
;===========================================================================
; Subject: VOXEL LANDSCAPE                    Date: 09-23-98 (22:33)
;  Author: Shawn                              Code: QB, QBasic, PDS
;  Origin: TopFiero@aol.com                 Packet: Graphics.ABC
;===========================================================================
;  BlitzPlus port by Andy Amaya


;AppTitle "QB Voxel Terrain Demo"

Global sw, sh, mx, my

screenSize = 3
Select screenSize
    Case 0: sw =  320: sh =  200
    Case 1: sw =  640: sh =  480
    Case 2: sw =  800: sh =  600
    Case 3: sw = 1024: sh =  768
    Case 5: sw = 1200: sh =  960
    Case 6: sw = 1600: sh = 1000
End Select

AppTitle "Voxel Terrain - "+sw

Dim pal%(230,2), img%(8), posx%(9), posy%(9)
Dim Z#(sw), X#(sw), CLR#(sw)
thumbWide% = 96
thumbHigh% = 60
Graphics sw,sh,32,2
SetBuffer BackBuffer()
SeedRnd( MilliSecs() )
For i = 0 To 999: Rnd(0.,999.):Next
loadMedia()

.begin
choice = menu()
Flip
If choice = 9 Then releaseMedia: End
Color 255,255,255
If screenSize > 0 Then
    Text sw/2,sh/2-thumbHigh*2-24,"Working...",True
    Flip
End If

st = MilliSecs()    

Cls

; (Uses palette entries 100 - 160)
PL = 0
For I = 100 To 160
    Select choice
        Case 1: pal(I,0) = 0: pal(I,1) = PL+11: pal(I,2) = PL+11            ;cyn
        Case 2: pal(I,0) = PL+11: pal(I,1) = PL: pal(I,2) = PL/4            ;yel
        Case 3: pal(I,0) = PL+3: pal(I,1) = (PL*.68): pal(I,2) = PL/32        ;brn
        Case 4: pal(I,0) = PL*.75+15: pal(I,1) = PL*.8+15: pal(I,2) = PL+15    ;wht
        Case 5: pal(I,0) = PL/2.5:pal(I,1) = PL/4: pal(I,2) = PL+11            ;pur
        Case 6: pal(I,0) = PL+11: pal(I,1) = PL/4: pal(I,2) = PL/3.5        ;red
        Case 7: pal(I,0) =  PL/8: pal(I,1) =   PL/4: pal(I,2) = PL+11        ;blu
        Case 8: pal(I,0) =  0: pal(I,1) =  PL: pal(I,2) = 4                    ;grn
    End Select
    PL = PL + 4
Next

;Set up sky/star palette using slots 170 - 230
PL = 0
For I = 170 To 230
    PLL = PL * 2
    If PLL > 254 Then PLL = 254
    pal(I,0) = PL: pal(I,1) = PL: pal(I,2) = PLL
    PL = PL + 4
Next

;Draw random stars in the sky
For I = 0 To 500
    rc = Rand(180,220)
    Color pal(rc,0), pal(rc,1), pal(rc,2)
    sx = Rand(1, sw-2) : sy = Rand(10, Int(sh*.6))
    ssz% = Rand(1,2)
    If ssz = 1 Then Plot sx, sy Else Rect sx,sy,ssz,ssz
Next

If Rand(0,99) < 33 Then
    ;Draw a glowing horizon background
    For I = 0 To 60
        Color pal(230-I,0), pal(230-I,1), pal(230-I,2)
        Rect 0, (sh/2-1)-I*6, sw,6,True
    Next
    Color pal(230,0), pal(230,1), pal(230,2)
    Rect 0, sh/2, sw, sh/8, True
Else
    ;Draw a diffuse star
    ZX = Rand(0,sw-100)
    ZY = Rand (6,sh/2)
    For I = 0 To 60
        Color pal(170+I,0), pal(170+I,1), pal(170+I,2)
        Oval ZX-(100-I), ZY-(100-I), (100-I) * 2, (100-I) * 2, True
    Next
End If


    ;Initialize terrain variables
    Z(0) = 0
   X(0) = sh/2
   SZ# = 1.0
   CLR(0) = 130
    CHK = 0
    
    ;Draw initial terrain horizon line
    For I = 1 To sw ;Int(sw*.77)
        Z(I) = Z(I - 1) + SZ
        X(I) = X(I - 1) - SZ + (SZ * 2) * Rnd(0., .999999)
        CLR(I) = CLR(I - 1) + Rand(-5,5)
        If CLR(I) < 100 Then CLR(I) = 100
        If CLR(I) > 160 Then CLR(I) = 160
        Color pal( CLR(I),0), pal( CLR(I),1), pal( CLR(I),2)
        Rect Z(I), X(I), SZ+4., SZ+4., True
        maxy = fMaxy( maxy,X(I) )
    Next
    Color pal(140,0),pal(140,1),pal(140,2)
    Rect 0,maxy, sw, sh-maxy,True

;Begin drawing voxel terrain
While CHK < sh+25
    CHK = 0
    SZ = SZ * 1.006 ;1.012 ;1.00328
    Z(0) = 0. - (SZ - 1.) * Float(sh Shr 1)
    X(0) = X(0) + SZ * Rnd(0., .999999)
    If KeyHit(1) Then Exit
    For I = 1 To sw
        Z(I) = Z(I - 1) + SZ
        X(I) = X(I) - SZ / 4. + SZ*Rnd(0., .999999)
        If X(I) < X(I - 1) - SZ Then X(I) = X(I - 1) - SZ
        If X(I) > X(I - 1) + SZ Then X(I) = X(I - 1) + SZ
        If Z(I) > -1 And Z(I) < sw Then
            CLR(I) = CLR(I) + Rnd(-4.,4.) ;-4 + Rand(0,7)
            If CLR(I) < CLR(I - 1) - 3 Then CLR(I) = CLR(I - 1) - 3
            If CLR(I) > CLR(I - 1) + 3 Then CLR(I) = CLR(I - 1) + 3
            If CLR(I) < 104 Then CLR(I) = 104
            If CLR(I) > 160 Then CLR(I) = 160
            Color pal( CLR(I),0), pal( CLR(I),1), pal( CLR(I),2)
            If SZ < 4.0 Then
                Rect Z(I), X(I), 5, 5,True
            Else
                Rect Z(I), X(I), SZ+5., SZ+5., True
            End If
        End If
        If X(I) > sh Then CHK = CHK + 1
        If CHK > (sh+24) Then
            exitWhileFlag = 1
            Exit
        End If
        If KeyHit(1) Then Exit
        ;Delay 1
    Next
    If KeyHit(1) Then Exit
    If exitWhileFlag = 1 Then Exit
    Delay 1
Wend


    et=MilliSecs()-st
    exitWhileFlag = 0
    Flip
    msg$ = "Terrain render finished."+Chr$(13)+Chr$(13)
    msg$ = msg$+"Right-click to save terrain image."+Chr$(13)
    msg$ = msg$+"Left-click for menu."
    Notify msg$

    click = WaitMouse()
    
    If click = 2 Then
        saveName$ = ""
        defaultName$ = "VoxTer-"+sw+"_01.bmp"
        saveName$ = RequestFile("Save As...","bmp",True,defaultName$)
        If saveName$ = "" Then
            Notify "Screen Save Cancelled."
        Else
            pic = CreateImage(sw,sh)
            GrabImage pic, 0, 0
            SaveImage pic, saveName$
            FreeImage pic
            Notify "Image "+saveName$+" successfully saved."
        End If
    End If
    Goto begin

Function fMaxy#(v1#, v2#)
    If v1>v2 Then Return v1 Else Return v2
End Function




Function loadMedia()
    For i = 1 To 8
        img(i) = LoadImage("thumb"+Str(i)+".png")
        If sw < 640 Then ResizeImage img(i), 72, 45
    Next
End Function

Function releaseMedia()
    For i = 1 To 8
        FreeImage img(i)
    Next
End Function

Function menu()
    Cls
    Color 64,192,255
    If sw<640 Then
        thWide% = 72: thHigh% = 45
        Text sw/2,16,"Click thumbnail to select a color",True
        k = 40: i = 1
        For j = 7 To 241 Step 78
            DrawBlock img(i),j,k
            DrawBlock img(i+4), j, k+thHigh+6
            posx(i) = j : posy(i) = k
            posx(i+4) = j: posy(i+4) = k+thHigh+6
            i = i + 1
        Next
        posx(9) = 124: posy(9) = 146:ty=k+thHigh*2+32
    Else
        thWide% = 96: thHigh = 60
        Text sw/2,sh/2-thHigh-26,"Click thumbnail to select a color",True
        k = sh/2-(thHigh+5): i = 1
        ox = (sw-(4*thWide+30))/2
        For j = ox To ox+(3*96+30) Step 96+10
            DrawBlock img(i),j,k
            DrawBlock img(i+4), j, k+thHigh+10
            posx(i) = j : posy(i) = k
            posx(i+4) = j: posy(i+4) = k+thHigh+10
            i = i + 1
        Next
        posx(9) = (sw-thWide)/2: posy(9) = k+140: ty=k+thHigh*2+42
    End If
    Color 255,255,255: Rect posx(9),posy(9),thWide,thHigh
    Color 255,0,0: Rect posx(9)+2,posy(9)+2,thWide-4,thHigh-4
    Color 255,255,255: Text sw/2,ty,"EXIT",True
                       Text sw/2-1,ty,"EXIT",True
    Flip
    FlushMouse()
    Repeat
        If KeyHit(1) Then releaseMedia : End
        If MouseHit(1) Then
            mx% = MouseX()
            my% = MouseY()
            For i = 1 To 9
                chk = pnr(mx, my, posx(i), posy(i), thWide, thHigh)
                If chk<>0 Then chk = i : Exit
                Delay 20
            Next
            If chk<>0 Then
                exitFlag = 1
                If chk < 9 Then
                    Color 255, 180, 32
                    Rect posx(chk)-4, posy(chk)-4,thWide+8, thHigh+8, True
                    DrawBlock img(chk), posx(chk), posy(chk)
                End If
                Flip
            End If
        End If
        Delay 20
    Until exitFlag = 1
    FlushMouse()
    Return chk
End Function
        
Function pnr(px, py, rx, ry, rw, rh)
;====================================================================================
;   Function "Point In Rectangle"
;====================================================================================
; This function determines if the point (px,py) is within the specified rectangle.
;
; If the point is inside the rectangle a value of 1 is returned.
;
; If the point is NOT inside the rectangle a value of 0 (zero) is returned.
;====================================================================================
; px = the X coord of the point in question
; py = the Y coord of the point in question
; rx = Upper  Left X coord of rectangle
; ry = Upper  Left Y coord of rectangle
; rw =  width of rectangle
; rh = height of rectangle
;====================================================================================
   Return ((px>=rx) And (px<=(rx+rw-1)) And (py>=ry) And (py<=(ry+rh-1)))
End Function

Attached are the thumbnails for the selection menu and source code.


Attached File(s)
.7z  VoxTer.7z (Size: 58.58 KB / Downloads: 4)
Find all posts by this user
Like Post
The following 1 user Likes Andy_A's post:
bplus



Forum Jump:


User(s) browsing this thread: 1 Guest(s)




QB64 Member Project - Algeria Weather
QB64 Member Project - Quarto
QB64 Member Project - 9 Board
QB64 Member Project - Pivet version one
QB64 Member Project - Sabotage
QB64 Member Project - Martin Fractals version two
QB64 Member Project - Dreamy Clock
QB64 Member Project - Isolation
QB64 Member Project - Martin Fractals version one
QB64 Member Project - Basic Dithering
QB64 Member Project - Martin Fractals version four
QB64 Member Project - ARB Checkers
QB64 Member Project - Rotating Background
QB64 Member Project - Foursight
QB64 Member Project - Dakapo
QB64 Member Project - OpenGL Triangles
QB64 Member Project - Qubic
QB64 Member Project - Exit
QB64 Member Project - Kings Valley verion one
QB64 Member Project - Inside Moves
QB64 Member Project - Kings Vallery version two
QB64 Member Project - Blokus
QB64 Member Project - Kings Court
QB64 Member Project - Score 4
QB64 Member Project - Red Scrolling LED Sign
QB64 Member Project - MAPTRIANGLE
QB64 Member Project - STxAxTIC 3D World
QB64 Member Project - Touche
QB64 Member Project - Kobolts Monopoly
QB64 Member Project - Color Rotating Text
QB64 Member Project - Input
QB64 Member Project - Color Triangles
QB64 Member Project - Spiro Roses
QB64 Member Project - Point Blank
QB64 Member Project - Rubix's Magic
QB64 Member Project - Splatter
QB64 Member Project - Full Color LED Sign
QB64 Member Project - Pivot version two
QB64 Member Project - Othello
QB64 Member Project - Swirl
QB64 Member Project - Domain
QB64 Member Project - Bowditch curve
QB64 Member Project - Martin Fractals version three
QB64 Member Project - Overboard
QB64 Member Project - RGB Color Wheel
QB64 Member Project - Spinning Color Wheel
QB64 Member Project - Connect Four
QB64 Member Project - Amazon
QB64 Member Project - Line Thickness