Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.

Topics - Ashish

Pages: [1] 2 3 4

Programs / JSON Reader

« on: August 03, 2021, 07:00:49 am »

Hello everyone!
I have coded a JSON reader. It can read a JSON string and it supports nested list, nested JSON objs and the mix of both
JSON obj and list.

Here is the code which contain JSON reader function -

Code: QB64: [Select]

Option _Explicit
$Console:Only
_Source _Console
Dim test$, l$
 
Open "test.json" For Binary As #1
test$ = Space$(LOF(1))
Get #1, , test$
Close #1
 
'label$ is case-sensitive
Do
    Input "label : ", l$ 'try .server-name or .roles.special.devs or roles.common.regulars.[1]
    Print json$(test$, l$)
Loop
 
'JSON Reader in QB64
'By AshishKingdom
Function json$ (json_data_0$, l$)
    If Len(json_data_0$) = 0 Or Len(l$) = 0 Then Exit Function
    If _Trim$(l$) = "." Then json$ = json_data_0$: Exit Function
 
    Dim As Long startPos, endPos, label_pos1, label_pos2, num_of_br
    Dim As Long f0, f1, f2, f3, f4, f5, f6, list_obj_pos
    Dim As _Byte value_type, in_quote '1=object, 2=array, 0=string or number
    Dim As String sep_type, curr_label, ca, label, json_data, tmp_str
    Dim As Long list_pos1, list_pos2, list_index
 
    label$ = l$
    json_data$ = json_data_0$
 
    json_list_sec:
 
    label_pos1 = InStr(label$, ".")
    If label_pos1 = 0 Then json$ = json_data$: Exit Function
    label_pos2 = InStr(label_pos1 + 1, label$, ".")
 
 
    list_pos1 = InStr(label$, "[")
    If list_pos1 Then
        If label_pos2 = 0 Then
            list_pos2 = InStr(list_pos1 + 1, label$, "]")
 
            If list_pos1 < label_pos1 Then Print "json_parser_error: '.' inside [] ": Exit Function
            If list_pos2 = 0 Then Print "json_parser_error: missing ] in label": Exit Function
 
            list_index = Val(Mid$(label$, list_pos1 + 1, list_pos2 - list_pos1 - 1))
            tmp_str = _Trim$(json_list(json_data$, list_index))
            json_data$ = tmp_str
            label$ = Right$(label$, Len(label$) - list_pos2)
            GoTo json_list_sec 'for nested list (if present), it will keep on parsing it
        Else
            If list_pos1 > label_pos1 And list_pos1 < label_pos2 Then
                'list index present
                list_pos2 = InStr(list_pos1 + 1, label$, "]")
                If list_pos2 = 0 Then Print "json_parser_error: missing ] in label": Exit Function
                If list_pos2 > label_pos2 Then Print "json_parser_error: '.' inside [] ": Exit Function
                list_index = Val(Mid$(label$, list_pos1 + 1, list_pos2 - list_pos1 - 1))
                tmp_str = _Trim$(json_list(json_data$, list_index))
                json_data$ = tmp_str
                label$ = Right$(label$, Len(label$) - list_pos2)
                GoTo json_list_sec 'for nested list (if present), it will keep on parsing it
            End If
        End If
    End If
 
    startPos = getAbsCharPos(json_data$, "{", 1)
    If startPos = 0 Then json$ = json_data$: Exit Function 'its not a json object then
    list_obj_pos = getAbsCharPos(json_data$, "[", 1)
    If startPos > list_obj_pos And list_obj_pos <> 0 Then Exit Function 'its probably a list
    endPos = charFind(json_data$, "}", 1, 1, 1)
    f0 = startPos + 1
    While 1
 
        f2 = getAbsCharPos(json_data$, ":", f0)
 
        If f2 = 0 Then Exit Function
        f1 = getAbsCharPos(json_data$, ",", f2 + 1)
 
        f5 = getAbsCharPos(json_data$, "[", f0)
        f6 = getAbsCharPos(json_data$, "{", f0)
        sep_type = ""
        If f5 = 0 And f6 = 0 Then
            f3 = 0
        ElseIf f5 = 0 And f6 > 0 Then
            f3 = f6
            sep_type = "}"
        ElseIf f6 = 0 And f5 > 0 Then
            f3 = f5
            sep_type = "]"
        ElseIf f5 < f6 And f5 <> 0 Then
            f3 = f5
            sep_type = "]"
        ElseIf f6 < f5 And f6 <> 0 Then
            f3 = f6
            sep_type = "}"
        End If
 
        If f3 = 0 Then
            value_type = 0
        Else
            'check if ',' was before [ or {
 
            If f1 < f3 And f1 <> 0 Then
                ' comma present before [ or {
                value_type = 0
            Else
                'comma present after.. so it may be inside {}/[] or outside of it.
                'finding end of position of json_obj/list present
                num_of_br = 1
                f4 = f3
                in_quote = 1
                While num_of_br > 0
                    f4 = f4 + 1
                    If f4 > endPos Then Print "json_parser_error: missing "; sep_type: Exit Function
 
                    ca = Mid$(json_data$, f4, 1)
                    If ca = Chr$(34) Then in_quote = in_quote * -1
                    If in_quote = 1 Then
                        If ca = "{" Or ca = "[" Then num_of_br = num_of_br + 1
                        If ca = "}" Or ca = "]" Then num_of_br = num_of_br - 1
                    End If
                Wend
                If sep_type = "}" Then value_type = 1 Else value_type = 2
            End If
        End If
 
 
        If f2 > f1 And f1 <> 0 Then
            Print "json_parser_error: ',' before ':'"
            Exit Function
        End If
        'Print value_type, f3, f4
        'Sleep
        If value_type = 0 Then
 
            If getData(Mid$(json_data$, f0, f2 - 1 - f0)) = Right$(label$, Len(label$) - 1) Then
                If f1 = 0 Then
                    json$ = getData(Mid$(json_data$, f2 + 1, endPos - f2 - 1))
                Else
                    json$ = getData(Mid$(json_data$, f2 + 1, f1 - f2 - 1))
                End If
                Exit Function
            Else
                If f1 = 0 Then Exit Function Else f0 = f1 + 1
            End If
        Else
            If label_pos2 = 0 Then
                curr_label = Right$(label$, Len(label$) - 1)
            Else
                curr_label = Mid$(label$, label_pos1 + 1, label_pos2 - label_pos1 - 1)
            End If
            'Print curr_label, getData(Mid$(json_data$, f0, f2 - 1 - f0))
            'Sleep
            If getData(Mid$(json_data$, f0, f2 - 1 - f0)) = curr_label Then
                If label_pos2 = 0 Then
                    json$ = Mid$(json_data$, f3, f4 - f3 + 1)
                    Exit Function
                Else
                    'Print Mid$(json_data$, f3, f4 - f3 + 1)
                    'Print Right$(label$, Len(label$) - label_pos2 + 1)
                    json$ = json$(Mid$(json_data$, f3, f4 - f3 + 1), Right$(label$, Len(label$) - label_pos2 + 1))
                    Exit Function
                End If
            Else
                f1 = getAbsCharPos(json_data$, ",", f4 + 1)
                If f1 = 0 Then f0 = f4 + 1 Else f0 = f1 + 1
                'Print "hha ", f1, f0
            End If
        End If
    Wend
End Function
 
Function json_list$ (list_data$, index As _Unsigned Long)
    If list_data$ = "" Then Exit Function
 
    Dim As Long startPos, endPos, curr_index, json_obj_pos, value_type
    Dim As Long f0, f1, f2, f3, f4, f5, f6, i
    Dim As Long num_of_br
    Dim As String ca, sep_type
    Dim As _Byte element_present, in_quote
 
    startPos = InStr(list_data$, "[")
    endPos = charFind(list_data$, "]", 0, 1, 1)
    If startPos = 0 Then json_list$ = list_data$: Exit Function 'its not a list
    json_obj_pos = getAbsCharPos(list_data$, "{", 1)
    If startPos > json_obj_pos And json_obj_pos <> 0 Then Exit Function 'probably its a json object
 
    f0 = startPos + 1
    curr_index = 0
    While 1
        f1 = getAbsCharPos(list_data$, ",", f0)
        '  f2 = getAbsCharPos(list_data$, "[", f0)
        f5 = getAbsCharPos(list_data$, "[", f0)
        f6 = getAbsCharPos(list_data$, "{", f0)
        sep_type = ""
        If f5 = 0 And f6 = 0 Then
            f3 = 0
        ElseIf f5 = 0 And f6 > 0 Then
            f3 = f6
            sep_type = "}"
        ElseIf f6 = 0 And f5 > 0 Then
            f3 = f5
            sep_type = "]"
        ElseIf f5 < f6 And f5 <> 0 Then
            f3 = f5
            sep_type = "]"
        ElseIf f6 < f5 And f6 <> 0 Then
            f3 = f6
            sep_type = "}"
        End If
 
        If f3 = 0 Then
            value_type = 0
        Else
            'check if ',' was before [ or {
 
            If f1 < f3 And f1 <> 0 Then
                ' comma present before [ or {
                value_type = 0
            Else
                'comma present after.. so it may be inside {}/[] or outside of it.
                'finding end of position of json_obj/list present
                num_of_br = 1
                f4 = f3
                in_quote = 1
                While num_of_br > 0
                    f4 = f4 + 1
                    If f4 > endPos Then Print "json_parser_error: missing "; sep_type: Exit Function
 
                    ca = Mid$(list_data$, f4, 1)
                    If ca = Chr$(34) Then in_quote = in_quote * -1
                    If in_quote = 1 Then
                        If ca = "{" Or ca = "[" Then num_of_br = num_of_br + 1
                        If ca = "}" Or ca = "]" Then num_of_br = num_of_br - 1
                    End If
                Wend
                f1 = f4 + 1
                If sep_type = "}" Then value_type = 1 Else value_type = 2
            End If
        End If
        'Print f0, f1, ca, curr_index, index
 
        If f1 = 0 Then
            'check if there's any value here
            If curr_index = index Then
                element_present = 0
 
                For i = f0 To endPos - 1
                    If Asc(Mid$(list_data$, i, 1)) <> 32 Then element_present = 1
                Next
                If element_present = 1 Then
                    If value_type = 0 Then
                        json_list$ = getData(Mid$(list_data$, f0, endPos - f0))
                    Else
                        json_list$ = Mid$(list_data$, f0, endPos - f0 + 1)
                    End If
                End If
            End If
            Exit Function
        Else
            If curr_index = index Then
                If value_type = 0 Then
                    json_list$ = getData(Mid$(list_data$, f0, f1 - f0))
                Else
                    json_list$ = Mid$(list_data$, f0, f1 - f0)
                End If
                Exit Function
            Else
                f0 = f1 + 1
            End If
        End If
        curr_index = curr_index + 1
    Wend
End Function
 
Function getAbsCharPos~& (main_str As String, char As String, s As _Unsigned Long) 'give position of char which is outside of quotes
    Dim As _Unsigned Long i, qp
    Dim ca$, q$
 
    qp = 1
    For i = s To Len(main_str)
        ca$ = Mid$(main_str, i, 1)
        If ca$ = Chr$(34) Then q$ = ca$: qp = qp * -1
        If ca$ = char And qp = 1 Then
            getAbsCharPos~& = i
            Exit Function
        End If
    Next
End Function
Function getData$ (main_str As String) 'quote_type=1("), 2=(')
    Dim quote$, i As _Unsigned Long, j As _Unsigned Long
    Dim c$
    If InStr(main_str, Chr$(34)) = 0 Then
        getData$ = _Trim$(main_str)
        'Print "yes"
        'Print main_str
        Exit Function
    End If
    For i = 1 To Len(main_str)
        c$ = Mid$(main_str, i, 1)
        If c$ = Chr$(34) Then
            quote$ = c$
            For j = i + 1 To Len(main_str)
                c$ = Mid$(main_str, j, 1)
                If c$ = quote$ Then Exit Function
                getData$ = getData$ + c$
            Next
        End If
    Next
End Function
Function charFind~& (main_str As String, search As String, p As _Unsigned Long, fromEnd As _Byte, ignore_quote As _Byte)
    If Len(main_str) = 0 Or Len(search) = 0 Then Exit Function
    Dim i As _Unsigned Long
    If fromEnd Then
        Dim reversed$
        For i = Len(main_str) To 1 Step -1
            reversed$ = reversed$ + Mid$(main_str, i, 1)
        Next
        'Print reversed$
        If ignore_quote Then charFind~& = -getAbsCharPos(reversed$, search, p) + 1 + Len(main_str) Else charFind~& = -InStr(p, reversed$, search) + 1 + Len(main_str)
    Else
        If ignore_quote Then charFind~& = getAbsCharPos(main_str, search, p) Else charFind~& = InStr(p, main_str, search)
    End If
End Function
 

Here is the test.json file which you need. Save the below JSON string into a file named test.json

Code: Text: [Select]

{
    "server-name" : "QB64",
    "description" : "Server for qb64, qbasic and gw-basic fans.",
    "roles" : {
        "special": {
            "devs" : ["Fellippe", "Luke", "Spriggsy", "SteveMcNeill"],
            "Crew-Members" : ["Ashish", "Cobalt", "Qwerky", "STxAxTIC"]
        },
        "common" : {
            "regulars" : ["Shalin", "Monke", "ChiaPet", "onecoding", "garbage", "loudar"]
        }
    },
    "total-members" : 296
}
 

Use "." followed a by label to get value. Use "[ index ]" for a list to get a value.

Programs / 3D World Game Engine

« on: May 29, 2021, 08:13:15 am »

Hey everyone! I started working on this first person engine 1 year ago... It can load 3d maps with objects to which you can interact..
I will love to see your feedbacks!

Instructions:

Move mouse to look around
Use W,S,A,D to move forward, backward, left and right respectively
Press SPACEBAR to pickup keys and to unlock the doors.
All game engine related debugging information is displayed in the console window... you can check for the cause of possible errors in the console window.
You will need world_data.cdf file in the same folder where executable is generated in order to work it properly. Download it from the attachment below

Here's the code -

Code: QB64: [Select]

'3D World Game Engine v1.0
'by Ashish
 
$Let DEBUG = -1
 
Declare Library 'camera control function
    Sub gluLookAt (ByVal eyeX#, Byval eyeY#, Byval eyeZ#, Byval centerX#, Byval centerY#, Byval centerZ#, Byval upX#, Byval upY#, Byval upZ#)
End Declare
 
Type vec3
    x As Single
    y As Single
    z As Single
End Type
 
Type map_element
    x As Single
    y As Single
    typ As Integer
    'below element can be use to store data for any application. (additional data)
    d_1 As Single
    d_2 As Single
    d_3 As Single
    d_4 As Single
End Type
Type map_file_header
    signature As String * 8 '3DM@QB64
    'objects
    num_of_wall As _Unsigned Integer
    num_of_floor As _Unsigned Integer
    num_of_ceiling As _Unsigned Integer
    num_of_door As _Unsigned Integer
    num_of_key As _Unsigned Integer
    num_of_point As _Unsigned Integer
    num_of_detail As _Unsigned Integer
    num_of_trap As _Unsigned Integer
    'dimension
    mapW As _Unsigned Integer
    mapH As _Unsigned Integer
    'player starting position
    px As Single
    py As Single
    'player destination position
    destX As Single
    destY As Single
    'global directional light settings
    light_amb As vec3 'ambient color
    light_diff As vec3 'diffuse color
    light_spec As vec3 'specular color
    light_dir As vec3 'direction of light
End Type
 
Type game_texture_type
    img_handle As Long
    gl_handle As Long
End Type
'For doors :-
'* d_2 specify the state of the door. 0=closed, 1=opening, 2=opened
'* d_1 specify which side of it is fixed. So, the door rotates from that side when being
' opened by the user. ±1=left ±2=right ±3=up ±4=down where sign (±) describe the direction of rotation when being open
'* d_3 specify the ID of the key from which it can be unlock and open
'* d_4 specify the angle of rotation when it is being open.
'For keys :-
'* d_1 specify its ID. Each key have a unique ID.
'* d_2 specify whether it has taken by the user or not. If taken, disable rendering of it.
'For traps :-
'* Type 1 [laser]
'  * d_4 is used as clock variable in timer
'  * d_2 is frequecncy of on/off of laser for every 4 seconds.
 
 
'Global Variables
Dim Shared worldStats As map_file_header
ReDim Shared wallMap(0) As map_element, floorMap(0) As map_element, ceilingMap(0) As map_element
ReDim Shared doorMap(0) As map_element, keyMap(0) As map_element, pointMap(0) As map_element
ReDim Shared detailMap(0) As map_element, trapMap(0) As map_element
 
Dim Shared worldTextures(7, 15) As game_texture_type '8 objects, each coming in maximum of 16 varities
 
Dim Shared game_state, worldRotX, worldRotY, playerPos As vec3, playerFarPoint
ReDim Shared collisionMap(0, 0, 1) As _Byte '2 layers, one for collision and second one for interaction with objects
 
 
'Local Variables
' dim preMouseX
Dim keyPressed As Long
 
_Title "3D World Game Engine v1.0"
Screen _NewImage(800, 600, 32)
_mousehide
$If DEBUG = -1 Then
    $Console
$End If
echo "3D World Game Engine v1.0"
echo "Preparing..."
 
'LOAD stuffs
loadResource
' for i = 0 to 15
' _putimage (0,0),worldTextures(0,i).img_handle
' sleep
' next
' worldTextures(0, 0).img_handle = _LOADIMAGE("Textures/wall/wall_1.jpg")
' worldTextures(1, 0).img_handle = _LOADIMAGE("Textures/floor/floor_1.jpg")
' worldTextures(2, 0).img_handle = _LOADIMAGE("Textures/ceiling/ceil_2.jpg")
' worldTextures(3, 0).img_handle = _LOADIMAGE("Textures/door/door_1.jpg")
 
' loadWorld "among_us_world.3dm"
playerPos.x = worldStats.px
playerPos.y = 0
playerPos.z = worldStats.py
playerFarPoint = 0.5
 
game_state = 1
Do
    While _MouseInput
    Wend
    
    keyPressed = _KeyHit
    
    worldRotX = map(_MouseY, 0, 600, 60, -60)
    
    ' if _MOUSEX >= _WIDTH - 1 then _mousemove 0,_mousey : preMouseX = 0
    
    worldRotY = worldRotY + (_MOUSEX - preMouseX)
    ' worldRotY = _D2R(_MouseX)
    
    check_key_input:
    __x1 = near_int(playerPos.x + 0.5 * Sin(_D2R(worldRotY)))
    __y1 = near_int(playerPos.z - 0.5 * Cos(_D2R(worldRotY)))
    ' If collisionMap(__x1, __y1, 1) = 1 Then echo "Ouch!!"
    If _KeyDown(Asc("w")) Or _KeyDown(Asc("W")) Then 'forward
        If collisionMap(__x1, __y1, 0) = 0 Then
            playerPos.x = playerPos.x + 0.08 * Sin(_D2R(worldRotY))
            playerPos.z = playerPos.z - 0.08 * Cos(_D2R(worldRotY))
        End If
    End If
    __x1 = near_int(playerPos.x - 0.5 * Sin(_D2R(worldRotY)))
    __y1 = near_int(playerPos.z + 0.5 * Cos(_D2R(worldRotY)))
    ' If collisionMap(__x1, __y1, 1) = 1 Then echo "Ouch!!"
    If _KeyDown(Asc("s")) Or _KeyDown(Asc("S")) Then 'backward, just doing opposite of forward
        If collisionMap(__x1, __y1, 0) = 0 Then
            playerPos.x = playerPos.x - 0.08 * Sin(_D2R(worldRotY))
            playerPos.z = playerPos.z + 0.08 * Cos(_D2R(worldRotY))
        End If
    End If
    __x1 = near_int(playerPos.x - 0.5 * Sin(_D2R(worldRotY + 90)))
    __y1 = near_int(playerPos.z + 0.5 * Cos(_D2R(worldRotY + 90)))
    ' If collisionMap(__x1, __y1, 1) = 1 Then echo "Ouch!!"
    If _KeyDown(Asc("a")) Or _KeyDown(Asc("A")) Then 'leftward
        If collisionMap(__x1, __y1, 0) = 0 Then
            playerPos.x = playerPos.x - 0.08 * Sin(_D2R(worldRotY + 90))
            playerPos.z = playerPos.z + 0.08 * Cos(_D2R(worldRotY + 90))
        End If
    End If
    __x1 = near_int(playerPos.x + 0.5 * Sin(_D2R(worldRotY + 90)))
    __y1 = near_int(playerPos.z - 0.5 * Cos(_D2R(worldRotY + 90)))
    ' If colslisionMap(__x1, __y1, 1) = 1 Then echo "Ouch!!" <--- temporarily commented
    If _KeyDown(Asc("d")) Or _KeyDown(Asc("D")) Then 'rightward, opposite of leftward
        If collisionMap(__x1, __y1, 0) = 0 Then
            playerPos.x = playerPos.x + 0.08 * Sin(_D2R(worldRotY + 90))
            playerPos.z = playerPos.z - 0.08 * Cos(_D2R(worldRotY + 90))
        End If
    End If
    'animation stuffs (khaaskar traps ke liye)
    If worldStats.num_of_trap > 0 Then
        For i = 1 To worldStats.num_of_trap
            If trapMap(i).typ = 1 Then 'laser
                If (Timer - trapMap(i).d_4) > (4 / trapMap(i).d_2) Then
                    If trapMap(i).d_3 = 1 Then
                        trapMap(i).d_3 = 0
                        collisionMap(trapMap(i).x, trapMap(i).y, 1) = 0 'no damage
                    Else
                        trapMap(i).d_3 = 1
                        collisionMap(trapMap(i).x, trapMap(i).y, 1) = 1 'damage
                    End If
                    trapMap(i).d_4 = Timer
                End If
            End If
        Next
    End If
    'interaction with objects
    If keyPressed = Asc(" ") Then
        __x1 = near_int(playerPos.x): __y1 = near_int(playerPos.z)
        __x2 = near_int(playerPos.x + 0.5 * Sin(_D2R(worldRotY))): __y2 = near_int(playerPos.z - 0.5 * Cos(_D2R(worldRotY)))
        'interaction with key
        If collisionMap(__x1, __y1, 1) = 3 Then
            'find by which key user have interacted?
            For i = 1 To worldStats.num_of_key
                If keyMap(i).d_2 = 0 Then
                    If keyMap(i).x = __x1 And keyMap(i).y = __y1 Then
                        keyMap(i).d_2 = 1 'disable rendering of the key as it is now taken by the user.
                        echo "KeyMap(" + _Trim$(Str$(i)) + ").d_2 = 1"
                        Exit For
                    End If
                End If
            Next
        End If
        'interaction with door
        If collisionMap(__x2, __y2, 1) = 2 Then
            'finding by which door user have interacted
            doorFound = 0
            For i = 1 To worldStats.num_of_door
                If doorMap(i).d_2 = 0 Then
                    If doorMap(i).x = __x2 And doorMap(i).y = __y2 Then
                        doorIndex = i
                        doorFound = 1
                        echo "door is found at index : " + Str$(doorIndex)
                    End If
                End If
            Next
            'checking if user has the key for this door
            If doorFound = 1 Then
                For i = 1 To worldStats.num_of_key
                    If doorMap(doorIndex).d_3 = keyMap(i).d_1 Then
                        If keyMap(i).d_2 = 1 Then
                            'okay, so the user do have the key for this door and the door is not yet opened.
                            'now, I change the state of this door from "closed" to "opening"
                            doorMap(doorIndex).d_2 = 1
                            echo "state of door is now changed."
                            Exit For
                        else
                            echo "You don't have key for this door... Try it find it somewhere"
                        End If
                    End If
                Next
            End If
        End If
    End If
    
    
    _Limit 30
    
    preMouseX = _MouseX
Loop
' for i = 1 to worldStats.num_of_wall
' pset (wallMap(i).x,wallMap(i).y)
' next
' for i = 1 to worldStats.num_of_floor
' pset (floorMap(i).x, floorMap(i).y), _RGB(255,0,0)
' next
 
Sub _GL ()
    Static tex_load_type
    If game_state = 0 Then Exit Sub
    If game_state = 1 Then
        ' If tex_load_type > 4 Then
            ' For i = 0 To UBound(playerTextures)
                ' playerTextures(i).gl_handle = feedGLTexture(playerTextures(i).img_handle)
                ' _FreeImage playerTextures(i).img_handle
            ' Next
            ' game_state = game_state + 1
            ' initPlayerObject
            ' Exit Sub
        ' End If
        For i = 0 To 15
            If worldTextures(tex_load_type, i).img_handle < -1 Then
                worldTextures(tex_load_type, i).gl_handle = feedGLTexture(worldTextures(tex_load_type, i).img_handle)
                _FreeImage worldTextures(tex_load_type, i).img_handle
            End If
        Next
        tex_load_type = tex_load_type + 1
        if tex_load_type>4 then game_state = game_state + 1
        Exit Sub
    End If
 
    If game_state = 2 Then 'world rendering
        _glViewport 0, 0, _Width, _Height
 
        _glEnable _GL_DEPTH_TEST
        _glEnable _GL_TEXTURE_2D
        _glEnable _GL_LIGHTING
        _glEnable _GL_BLEND
        _glDisable _GL_MULTISAMPLE
        
        'Global Light Settings of World
        _glEnable _GL_LIGHT0
        _glLightfv _GL_LIGHT0, _GL_AMBIENT, glVec4(worldStats.light_amb.x, worldStats.light_amb.y, worldStats.light_amb.z, 1)
        _glLightfv _GL_LIGHT0, _GL_DIFFUSE, glVec4(worldStats.light_diff.x, worldStats.light_diff.y, worldStats.light_diff.z, 1)
        _glLightfv _GL_LIGHT0, _GL_SPECULAR, glVec4(worldStats.light_spec.x, worldStats.light_spec.y, worldStats.light_spec.z, 1)
        _glLightfv _GL_LIGHT0, _GL_POSITION, glVec4(worldStats.light_dir.x, worldStats.light_dir.y, worldStats.light_dir.z, 1)
 
        _glMatrixMode _GL_PROJECTION
        _glLoadIdentity
        _gluPerspective 60, _width/_Height, 0.1, worldStats.mapW
        
        _glMatrixMode _GL_MODELVIEW
        _glLoadIdentity
        '_glTranslatef playerPos.x, 1, playerPos.z
        ' _glRotatef worldRotX, 1, 0, 0
        ' _glRotatef worldRotY+180, 0, 1, 0
        
        gluLookAt playerPos.x , playerPos.y + 0.4, playerPos.z,_
playerPos.x + playerFarPoint * Cos(_D2R(worldRotY-90)), playerPos.y+0.4*sin(_d2r(worldRotX)) , playerPos.z + playerFarPoint * Sin(_D2R(worldRotY-90)),_
 0, 1, 0
 
        drawWalls
        drawDoors
        drawFloors
        drawCeilings
        drawKeys
        drawBonusObj
        drawTraps
 
        _glFlush
    End If
End Sub
 
Sub loadResource ()
    Dim n, i, j, k, f$
    n = 15
    echo "------------In SUB loadResource()------------------"
    echo "extracting map and textures"
    
    extract_file_all "world_data.cdf", "./"
    
    extract_file_all "wall.cdf", "./"
    
    'wall textures
    For i = 0 To n
        ' worldTextures(0, i).img_handle = _LoadImage("Textures/wall/wall_" + _Trim$(Str$(i + 1)) + ".png")
        f$ = "wall_" + _Trim$(Str$(i + 1)) + ".png"
        worldTextures(0, i).img_handle = _LoadImage(f$)
        kill f$
    Next
    kill "wall.cdf"
    echo "wall... DONE"
    
    'floor textures
    extract_file_all "floor.cdf", "./"
    For i = 0 To n
        f$ = "floor_" + _Trim$(Str$(i + 1)) + ".jpg"
        ' worldTextures(1, i).img_handle = _LoadImage("Textures/floor/floor_" + _Trim$(Str$(i + 1)) + ".jpg")
        worldTextures(1, i).img_handle = _LoadImage(f$)
        kill f$
    Next
    kill "floor.cdf"
    echo "floor... DONE"
    'ceiling textures
    extract_file_all "ceil.cdf","./"
    n = 2
    For i = 0 To n
        f$ = "ceil_" + _Trim$(Str$(i + 1)) + ".jpg"
        ' worldTextures(2, i).img_handle = _LoadImage("Textures/ceiling/ceil_" + _Trim$(Str$(i + 1)) + ".jpg")
        worldTextures(2, i).img_handle = _LoadImage(f$)
        kill f$
    Next
    kill "ceil.cdf"
    echo "ceiling... DONE"
    'door textures
    extract_file_all "door.cdf", "./"
    n = 6
    For i = 0 To n
        f$ = "door_" + _Trim$(Str$(i + 1)) + ".jpg"
        ' worldTextures(3, i).img_handle = _LoadImage("Textures/door/door_" + _Trim$(Str$(i + 1)) + ".jpg")
        worldTextures(3, i).img_handle = _LoadImage(f$)
        kill f$
    Next
    kill "door.cdf"
    echo "door... DONE"
    'key textures
    extract_file_all "key.cdf", "./"
    n = 7
    For i = 0 To n
        For j = 1 To 2
            f$ = "key_" + _Trim$(Str$(i + 1)) + "_" + _Trim$(Str$(j)) + ".png"
            ' worldTextures(4, k).img_handle = _LoadImage("Textures/key/key_" + _Trim$(Str$(i + 1)) + "_" + _Trim$(Str$(j)) + ".png")
            worldTextures(4, k).img_handle = _LoadImage(f$)
            k = k + 1
            kill f$
        Next
        kill "key_"+_Trim$(Str$(i + 1))+".png"
    Next
    kill "key.cdf"
    echo "key... DONE"
    echo ""
    echo "Loading Map"
    loadWorld "test.3dm"
    kill "test.3dm"
    
    
End Sub
 
Sub drawWalls ()
    For i = 1 To worldStats.num_of_wall
        selectTexture worldTextures(0, wallMap(i).typ - 1).gl_handle
        ' drawBox wallMap(i).x, 0, wallMap(i).y, 1, 2, 1
        drawXYPlane wallMap(i).x, 0, wallMap(i).y - 0.5, 1, 2, -1 'front face
        drawXYPlane wallMap(i).x, 0, wallMap(i).y + 0.5, 1, 2, 1 'back face
        drawYZPlane wallMap(i).x - 0.5, 0, wallMap(i).y, 2, 1, -1 'left face
        drawYZPlane wallMap(i).x + 0.5, 0, wallMap(i).y, 2, 1, 1 'right face
    Next
End Sub
 
Sub drawFloors ()
    _glMaterialfv _GL_FRONT_AND_BACK, _GL_SHININESS, glVec4(0.5 * 128, 0, 0, 0)
    For i = 1 To worldStats.num_of_floor
        selectTexture worldTextures(1, floorMap(i).typ - 1).gl_handle
        drawXZPlane floorMap(i).x, -1, floorMap(i).y, 1, 1, 1
    Next
End Sub
 
Sub drawCeilings ()
    For i = 1 To worldStats.num_of_ceiling
        selectTexture worldTextures(2, ceilingMap(i).typ - 1).gl_handle
        drawXZPlane ceilingMap(i).x, 1, ceilingMap(i).y, 1, 1, -1
    Next
End Sub
 
Sub drawDoors ()
    '±1,±2,±3,,
    For i = 1 To worldStats.num_of_door
        selectTexture worldTextures(3, doorMap(i).typ - 1).gl_handle
        If doorMap(i).d_2 = 0 Then 'closed?
            If Abs(doorMap(i).d_1) = 1 Or Abs(doorMap(i).d_1) = 2 Then
                'it must be slim in XY depth
                drawXYPlane doorMap(i).x, 0, doorMap(i).y - 0.1, 1, 2, -1 'front face
                drawXYPlane doorMap(i).x, 0, doorMap(i).y + 0.1, 1, 2, 1 'back face
                
                drawYZPlane doorMap(i).x - 0.5, 0, doorMap(i).y, 2, 0.2, -1 'left face
                drawYZPlane doorMap(i).x + 0.5, 0, doorMap(i).y, 2, 0.2, 1 'right face
            Else
                drawXYPlane doorMap(i).x, 0, doorMap(i).y - 0.5, 0.2, 2, -1 'front face
                drawXYPlane doorMap(i).x, 0, doorMap(i).y + 0.5, 0.2, 2, 1 'back face
                
                'it must be slim in YZ along X
                drawYZPlane doorMap(i).x - 0.1, 0, doorMap(i).y, 2, 1, -1 'left face
                drawYZPlane doorMap(i).x + 0.1, 0, doorMap(i).y, 2, 1, 1 'right face
            End If
        ElseIf doorMap(i).d_2 = 1 Then 'opening
            If doorMap(i).d_1 > 0 Then s = 1 Else s = -1
            If Abs(doorMap(i).d_1) = 1 Then 'left
                _glPushMatrix
                _glTranslatef doorMap(i).x - 0.5, 0, doorMap(i).y
                _glRotatef doorMap(i).d_4, 0, 1, 0
 
                If doorMap(i).d_4 = 90 * s Then collisionMap(doorMap(i).x, doorMap(i).y, 0) = 0 Else doorMap(i).d_4 = doorMap(i).d_4 + 2 * s
                drawXYPlane 0.5, 0, -0.1, 1, 2, -1 'front face
                drawXYPlane 0.5, 0, 0.1, 1, 2, 1 'back face
                
                drawYZPlane 0, 0, 0, 2, 0.2, -1 'left face
                drawYZPlane 1, 0, 0, 2, 0.2, 1 'right face
                _glPopMatrix
            ElseIf Abs(doorMap(i).d_1) = 2 Then 'right
                _glPushMatrix
                _glTranslatef doorMap(i).x + 0.5, 0, doorMap(i).y
                _glRotatef doorMap(i).d_4, 0, 1, 0
                
                If doorMap(i).d_4 = 90 * s Then collisionMap(doorMap(i).x, doorMap(i).y, 0) = 0 Else doorMap(i).d_4 = doorMap(i).d_4 + 2 * s
                drawXYPlane -0.5, 0, -0.1, 1, 2, -1 'front face
                drawXYPlane -0.5, 0, 0.1, 1, 2, 1 'back face
                
                drawYZPlane -1, 0, 0, 2, 0.2, -1 'left face
                drawYZPlane 0, 0, 0, 2, 0.2, 1 'right face
                _glPopMatrix
            ElseIf Abs(doorMap(i).d_1) = 3 Then 'up
                _glPushMatrix
                _glTranslatef doorMap(i).x, 0, doorMap(i).y - 0.5
                _glRotatef doorMap(i).d_4, 0, 1, 0
                If doorMap(i).d_4 = 90 * s Then collisionMap(doorMap(i).x, doorMap(i).y, 0) = 0 Else doorMap(i).d_4 = doorMap(i).d_4 + 2 * s
                drawXYPlane 0, 0, 0, 0.2, 2, -1 'front face
                drawXYPlane 0, 0, 1, 0.2, 2, 1 'back face
                
                drawYZPlane -0.1, 0, 0.5, 2, 1, -1 'left face
                drawYZPlane 0.1, 0, 0.5, 2, 1, 1 'right face
                _glPopMatrix
            Else 'down
                _glPushMatrix
                _glTranslatef doorMap(i).x, 0, doorMap(i).y + 0.5
                _glRotatef doorMap(i).d_4, 0, 1, 0
 
                If doorMap(i).d_4 = 90 * s Then collisionMap(doorMap(i).x, doorMap(i).y, 0) = 0 Else doorMap(i).d_4 = doorMap(i).d_4 + 2 * s
                drawXYPlane 0, 0, -1, 0.2, 2, -1 'front face
                drawXYPlane 0, 0, 0, 0.2, 2, 1 'back face
                
                drawYZPlane -0.1, 0, -0.5, 2, 1, -1 'left face
                drawYZPlane 0.1, 0, -0.5, 2, 1, 1 'right face
                _glPopMatrix
            End If
        End If
    Next
End Sub
 
 
Sub drawKeys ()
    Static keyRotY
    keyRotY = keyRotY + 1
    _glDisable _GL_LIGHTING
    For i = 1 To worldStats.num_of_key
        If keyMap(i).d_2 = 0 Then 'd_2 store whether it has been taken by the user or not.
            _glPushMatrix
            _glTranslatef keyMap(i).x, -.98, keyMap(i).y
            _glRotatef keyRotY, 0, 1, 0
            selectTexture worldTextures(4, keyMap(i).typ - 1).gl_handle
            drawXZPlane 0, 0, 0, .25, .15, 1
            _glPopMatrix
        End If
    Next
    _glEnable _GL_LIGHTING
End Sub
 
 
Sub drawBonusObj ()
    Static calc_done As _Byte, sin120, cos120, sin240, cos240, rotY
    If calc_done = 0 Then
        calc_done = 1
        sin120 = Sin(_D2R(120))
        cos120 = Cos(_D2R(120))
        sin240 = Sin(_D2R(240))
        cos240 = Cos(_D2R(240))
    End If
    rotY = rotY + 2
    r = 0.2: yOff = -0.6
    _glDisable _GL_LIGHTING
    For i = 1 To worldStats.num_of_point
        _glPushMatrix
        _glTranslatef pointMap(i).x, 0, pointMap(i).y
        _glRotatef rotY, 0, 1, 0
        _glBegin _GL_TRIANGLES
        'down open pyramid
        _glColor3f 0, 1, 1
        _glVertex3f 0, -r + yOff, 0
        _glVertex3f r, yOff, 0
        _glVertex3f r * cos120, yOff, r * sin120
        _glColor3f 1, 0, 1
        _glVertex3f 0, -r + yOff, 0
        _glVertex3f r * cos120, yOff, r * sin120
        _glVertex3f r * cos240, yOff, r * sin240
        _glColor3f 1, 1, 0
        _glVertex3f 0, -r + yOff, 0
        _glVertex3f r, yOff, 0
        _glVertex3f r * cos240, yOff, r * sin240
        'upper open pyramid, combined together with to form a diamond like structure
        _glColor3f 1, 0, 1
        _glVertex3f 0, r + yOff, 0
        _glVertex3f r, yOff, 0
        _glVertex3f r * cos120, yOff, r * sin120
        _glColor3f 1, 1, 0
        _glVertex3f 0, r + yOff, 0
        _glVertex3f r * cos120, yOff, r * sin120
        _glVertex3f r * cos240, yOff, r * sin240
        _glColor3f 0, 1, 1
        _glVertex3f 0, r + yOff, 0
        _glVertex3f r, yOff, 0
        _glVertex3f r * cos240, yOff, r * sin240
        _glEnd
        _glPopMatrix
    Next
    _glEnable _GL_LIGHTING
End Sub
 
Sub drawTraps ()
    _glDisable _GL_LIGHTING
    If worldStats.num_of_trap > 0 Then
        For i = 1 To worldStats.num_of_trap
            Select Case trapMap(i).typ
                Case 1 'laser trap
                    If trapMap(i).d_3 = 1 Then
                        If trapMap(i).d_1 = 1 Then 'aage piche w.r.t. XY plane
                            _glColor3f 1, 0, 0
                            selectTexture 0
                            _glLineWidth 3.0
                            _glBegin _GL_LINES
                            For j = -0.8 To 0.8 Step 0.4
                                _glVertex3f trapMap(i).x - 0.5, j, trapMap(i).y - 0.5
                                _glVertex3f trapMap(i).x - 0.5, j, trapMap(i).y + 0.5
                                
                                _glVertex3f trapMap(i).x + 0.5, j, trapMap(i).y - 0.5
                                _glVertex3f trapMap(i).x + 0.5, j, trapMap(i).y + 0.5
                            Next
                            _glEnd
                        Else 'agal bagal w.r.t. XY Plane
                            _glColor3f 1, 0, 0
                            selectTexture 0
                            _glLineWidth 3.0
                            _glBegin _GL_LINES
                            For j = -0.8 To 0.8 Step 0.4
                                _glVertex3f trapMap(i).x - 0.5, j, trapMap(i).y - 0.5
                                _glVertex3f trapMap(i).x + 0.5, j, trapMap(i).y - 0.5
                                
                                _glVertex3f trapMap(i).x - 0.5, j, trapMap(i).y + 0.5
                                _glVertex3f trapMap(i).x + 0.5, j, trapMap(i).y + 0.5
                            Next
                            _glEnd
                        End If
                    End If
            End Select
        Next
    End If
    _glEnable _GL_LIGHTING
End Sub
 
Sub drawBox (x, y, z, w, h, d) '(x,y,z)->location to draw, w->width, h->height, d-depth of the box
    'XY
    drawXYPlane x, y, z - d / 2, w, h, -1
    drawXYPlane x, y, z + d / 2, w, h, 1
    'YZ
    drawYZPlane x - w / 2, y, z, h, d, -1
    drawYZPlane x + w / 2, y, z, h, d, 1
    'XZ
    drawXZPlane x, y - h / 2, z, w, d, -1
    drawXZPlane x, y + h / 2, z, w, d, 1
End Sub
 
Sub drawXZPlane (x, y, z, w, d, n) '(x,z)->location to draw, w->width, d->depth of the plane, n->normal direction in Y direction
    _glBegin _GL_QUADS
    _glTexCoord2f 1, 0
    _glNormal3f 0, n, 0
    _glVertex3f x - (w / 2), y, z - d / 2
    _glTexCoord2f 1, 1
    _glNormal3f 0, n, 0
    _glVertex3f x + (w / 2), y, z - d / 2
    _glTexCoord2f 0, 1
    _glNormal3f 0, n, 0
    _glVertex3f x + (w / 2), y, z + d / 2
    _glTexCoord2f 0, 0
    _glNormal3f 0, n, 0
    _glVertex3f x - (w / 2), y, z + d / 2
    _glEnd
End Sub
 
Sub drawXYPlane (x, y, z, w, h, n) '(x,y)-> location to draw, w->width, h->height, n->normal direction in Z direction
    _glBegin _GL_QUADS
    _glTexCoord2f 0, 0
    _glNormal3f 0, 0, n
    _glVertex3f x - (w / 2), y - h / 2, z
    _glTexCoord2f 1, 0
    _glNormal3f 0, 0, n
    _glVertex3f x + (w / 2), y - h / 2, z
    _glTexCoord2f 1, 1
    _glNormal3f 0, 0, n
    _glVertex3f x + (w / 2), y + h / 2, z
    _glTexCoord2f 0, 1
    _glNormal3f 0, 0, n
    _glVertex3f x - (w / 2), y + h / 2, z
    _glEnd
End Sub
 
Sub drawYZPlane (x, y, z, h, d, n) '(y,z)->location to draw, h->height, d->depth, n->normal direction in X direction
    _glBegin _GL_QUADS
    _glTexCoord2f 0, 0
    _glNormal3f n, 0, 0
    _glVertex3f x, y - (h / 2), z - d / 2
    _glTexCoord2f 0, 1
    _glNormal3f n, 0, 0
    _glVertex3f x, y + (h / 2), z - d / 2
    _glTexCoord2f 1, 1
    _glNormal3f n, 0, 0
    _glVertex3f x, y + (h / 2), z + d / 2
    _glTexCoord2f 1, 0
    _glNormal3f n, 0, 0
    _glVertex3f x, y - (h / 2), z + d / 2
    _glEnd
End Sub
 
Sub selectTexture (tex&)
    _glTexParameteri _GL_TEXTURE_2D, _GL_TEXTURE_MAG_FILTER, _GL_LINEAR
    _glTexParameteri _GL_TEXTURE_2D, _GL_TEXTURE_MIN_FILTER, _GL_LINEAR
    _glBindTexture _GL_TEXTURE_2D, tex&
End Sub
 
Function feedGLTexture& (img As Long)
    If img < -1 Then
        Dim m As _MEM
        m = _MemImage(img)
 
        _glGenTextures 1, _Offset(feedGLTexture&)
        _glBindTexture _GL_TEXTURE_2D, feedGLTexture&
 
        _glTexImage2D _GL_TEXTURE_2D, 0, _GL_RGBA, _Width(img&), _Height(img&), 0, _GL_BGRA_EXT, _GL_UNSIGNED_BYTE, m.OFFSET
 
        _MemFree m
        _glTexParameteri _GL_TEXTURE_2D, _GL_TEXTURE_MAG_FILTER, _GL_LINEAR
        _glTexParameteri _GL_TEXTURE_2D, _GL_TEXTURE_MIN_FILTER, _GL_NEAREST
 
    Else
        echo "FUNCTION feedGlTexture&() : invalid image handle passed"
    End If
End Function
 
Sub loadWorld (map_file$) 'load the given .3dm world
    If Not _FileExists(map_file$) Then echo "SUB loadWorld() : map file not found - " + map_file$: Exit Sub
 
    f = FreeFile
    Open map_file$ For Binary As #f
    Get #f, , worldStats
 
    If worldStats.signature <> "3DM@QB64" Then echo "SUB loadWorld() : Invalid Signature - " + map_file$: Exit Sub
    
    'show map info in debug mode
    echo "SUB loadWorld() : Map file loaded - " + map_file$
    echo "World size : " + Str$(worldStats.mapW) + "x" + Str$(worldStats.mapH)
    echo "Player initial position : " + Str$(worldStats.px) + "," + Str$(worldStats.py)
    echo "Number of wall block(s) : " + Str$(worldStats.num_of_wall)
    echo "Number of floor block(s) : " + Str$(worldStats.num_of_floor)
    echo "Number of ceiling block(s) : " + Str$(worldStats.num_of_ceiling)
    echo "Number of door(s) : " + Str$(worldStats.num_of_door)
    echo "Number of key(s) : " + Str$(worldStats.num_of_key)
    echo "Number of point(s) : " + Str$(worldStats.num_of_point)
    echo "Number of detail(s)/interior(s) : " + Str$(worldStats.num_of_detail)
    echo "Number of trap(s) : " + Str$(worldStats.num_of_trap)
    echo "Player destination : " + Str$(worldStats.destX) + "," + Str$(worldStats.destY)
    echo "Global Light Settings :- "
    echo "Ambient Color : (" + Str$(worldStats.light_amb.x) + "," + Str$(worldStats.light_amb.y) + "," + Str$(worldStats.light_amb.z) + ")"
    echo "Diffuse Color : (" + Str$(worldStats.light_diff.x) + "," + Str$(worldStats.light_diff.y) + "," + Str$(worldStats.light_diff.z) + ")"
    echo "Specular Color : (" + Str$(worldStats.light_spec.x) + "," + Str$(worldStats.light_spec.y) + "," + Str$(worldStats.light_spec.z) + ")"
    echo "Direction : (" + Str$(worldStats.light_dir.x) + "," + Str$(worldStats.light_dir.y) + "," + Str$(worldStats.light_dir.z) + ")"
    'wall
    If worldStats.num_of_wall > 0 Then
        ReDim wallMap(worldStats.num_of_wall) As map_element
        For i = 1 To worldStats.num_of_wall
            Get #f, , wallMap(i)
        Next
    End If
    'floor
    If worldStats.num_of_floor > 0 Then
        ReDim floorMap(worldStats.num_of_floor) As map_element
        For i = 1 To worldStats.num_of_floor
            Get #f, , floorMap(i)
        Next
    End If
    'ceiling
    If worldStats.num_of_ceiling > 0 Then
        ReDim ceilingMap(worldStats.num_of_ceiling) As map_element
        For i = 1 To worldStats.num_of_ceiling
            Get #f, , ceilingMap(i)
        Next
    End If
    'door
    If worldStats.num_of_door > 0 Then
        ReDim doorMap(worldStats.num_of_door) As map_element
        For i = 1 To worldStats.num_of_door
            Get #f, , doorMap(i)
        Next
    End If
    'keys
    If worldStats.num_of_key > 0 Then
        ReDim keyMap(worldStats.num_of_key) As map_element
        For i = 1 To worldStats.num_of_key
            Get #f, , keyMap(i)
        Next
    End If
    'point
    If worldStats.num_of_point > 0 Then
        ReDim pointMap(worldStats.num_of_point) As map_element
        For i = 1 To worldStats.num_of_point
            Get #f, , pointMap(i)
        Next
    End If
    
    If worldStats.num_of_detail > 0 Then
        ReDim detailMap(worldStats.num_of_detail) As map_element
        For i = 1 To worldStats.num_of_detail
            Get #f, , detailMap(i)
        Next
    End If
 
    If worldStats.num_of_trap > 0 Then
        ReDim trapMap(worldStats.num_of_trap) As map_element
        For i = 1 To worldStats.num_of_trap
            Get #f, , trapMap(i)
        Next
    End If
 
    Close #f
    
    'generate new collision map
    ReDim collisionMap(worldStats.mapW, worldStats.mapH, 1) As _Byte
    For i = 1 To worldStats.num_of_wall
        collisionMap(wallMap(i).x, wallMap(i).y, 0) = 1
    Next
    For i = 1 To worldStats.num_of_door
        collisionMap(doorMap(i).x, doorMap(i).y, 0) = 1
        collisionMap(doorMap(i).x, doorMap(i).y, 1) = 2
    Next
    For i = 1 To worldStats.num_of_key
        collisionMap(keyMap(i).x, keyMap(i).y, 1) = 3
    Next
    
End Sub
 
Function near_int (c)
    If (c - Int(c)) >= 0.5 Then near_int = Int(c) + 1 Else near_int = Int(c)
End Function
 
Sub echo (a$)
    $If DEBUG = -1 Then
        _Echo a$
    $End If
End Sub
 
Function glVec4%& (x, y, z, w)
    Static internal_vec4(3)
    internal_vec4(0) = x
    internal_vec4(1) = y
    internal_vec4(2) = z
    internal_vec4(3) = w
    glVec4%& = _Offset(internal_vec4())
End Function
 
Function map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
End Function
 
 
'supportive functions
 
'##################################################################################
'syntax: extract_file_all cdf_file_name$, path_where_file_is_to_be_extracted$
'* extract all the files present in the given cdf file.
'  path_where_file_is_to_be_extracted$ must end either with '/' or '\'
'##################################################################################
sub extract_file_all (f_name$, path$)
    ' $CHECKING:OFF
    DIM header AS cdf_file_header, element AS cdf_file_element
    dim fileToBeExtracted$
 
    IF _FILEEXISTS(f_name$) THEN
        f = FREEFILE
        OPEN f_name$ FOR BINARY AS #f
        GET #f, , header
        IF header.signature <> "cdf@qb64" THEN CLOSE #f: echo "In SUB extract_file_all(): Invalid file - "+f_name$: EXIT SUB 'verify if it is even a cdf_file or not. Then only proceed.
 
        FOR i = 1 TO header.num_of_files
            GET #f, , element
 
                        a$ = SPACE$(element.compressed_bytes)
                        GET #f, , a$ 'get content
            fileToBeExtracted$ = _TRIM$(element.file_name)
                        ff = FREEFILE
                        IF _FILEEXISTS(path$ + fileToBeExtracted$) THEN KILL path$ + fileToBeExtracted$ 'delete if there already exists a file with the same name
                        ea$ = _INFLATE$(a$, element.original_bytes) 'decompress
            echo path$+fileToBeExtracted$
                        OPEN path$ + fileToBeExtracted$ FOR BINARY AS #ff 'create the file at the output path
                        PUT #ff, , ea$
                        CLOSE #ff
        NEXT
        CLOSE #f
        else
                echo "In SUB extract_file_all(): File "+f_name$+" not found."
    END IF
    ' $CHECKING:ON
end sub
 
'####################################################################################
'syntax: extract_file cdf_file_name$, name_of_file_To_Be_Extracted$, output_path$
'* extract the given file from cdf_file if it exists in it to the required
'  output path. output_path$ must end with either '/' or '\'.
'#####################################################################################
SUB extract_file (f_name$, fileToBeExtracted$, path$)
    ' $CHECKING:OFF
    DIM header AS cdf_file_header, element AS cdf_file_element
 
    IF _FILEEXISTS(f_name$) THEN
        f = FREEFILE
        OPEN f_name$ FOR BINARY AS #f
        GET #f, , header
        IF header.signature <> "cdf@qb64" THEN CLOSE #f: echo "In SUB extract_file(): Invalid file - "+f_name$: EXIT SUB 'verify if it is even a cdf_file or not. Then only proceed.
 
        FOR i = 1 TO header.num_of_files
            GET #f, , element
            IF RTRIM$(element.file_name) = fileToBeExtracted$ THEN 'extract the file, if condition become true
' ?"ok"
                a$ = SPACE$(element.compressed_bytes)
                GET #f, , a$ 'get content
                ff = FREEFILE
                IF _FILEEXISTS(path$ + fileToBeExtracted$) THEN KILL path$ + fileToBeExtracted$ 'delete if there already exists a file with the same name
                ea$ = _INFLATE$(a$, element.original_bytes) 'decompress
                OPEN path$ + fileToBeExtracted$ FOR BINARY AS #ff 'create the file at the output path
                PUT #ff, , ea$
                CLOSE #ff
                EXIT SUB
            ELSE
                SEEK f, SEEK(f) + element.compressed_bytes 'file name is not one which user looking for, we just skip to next entry
            END IF
        NEXT
        CLOSE #f
        else
                echo "In SUB extract_file(): File not found - "+f_name$
    END IF
    ' $CHECKING:ON
END SUB
 
SUB __internal_dummy_cdf_sub () 'declare required types
    TYPE cdf_file_header
        signature AS STRING * 8 'cdf@qb64
        num_of_files AS INTEGER
    END TYPE
 
    TYPE cdf_file_element
        file_name AS STRING * 128
        original_bytes AS _UNSIGNED _INTEGER64
        compressed_bytes AS _UNSIGNED _INTEGER64
    END TYPE
END SUB
 

Programs / Old Skool Plasma Effect

« on: May 24, 2021, 08:06:51 am »

Hey guys! Currently, I'm learning GLSL and I recently created shader of plasma
effect - https://www.shadertoy.com/view/NllGRM which ChiaPet asked me convert it to QB64 at Discord
So, I converted it to QB64. :)

Code: QB64: [Select]

'conversion of https://www.shadertoy.com/view/NllGRM
'in QB64 By Ashish for Richard
'24 May, 2021
_Title "PLASMA EFFECT"
Screen _NewImage(400, 400, 32)
Type vec3
    As Single x, y, z
End Type
Dim clr As vec3, final As vec3
Dim iTime As Single, i As Single, j As Single, t As Single
Dim u As Single, v As Single
iTime = 0
Do
    For i = 0 To 400
        For j = 0 To 400
            u = j / 400
            v = i / 400
            t = Abs(Sin(15 * ((u - 0.5 + 0.3 * Sin(iTime * 2)) ^ 2 + (v - 0.5 + 0.3 * Cos(iTime * 2)) ^ 2) ^ 0.5 - iTime * 5))
            clr.x = t: clr.y = 1 - t: clr.z = 1 - t
            final = clr
            t = Cos(u * 20 + iTime * 5) ^ 2
            clr.x = 1 - t: clr.y = t: clr.z = 0
            final.x = final.x + clr.x
            final.y = final.y + clr.y
            final.z = final.z + clr.z
            PSet (j, i), _RGB32(final.x * 255, final.y * 255, final.z * 255)
        Next j
    Next i
    _Display
    iTime = iTime + 0.05
Loop
 

Programs / Music Visualiser 2D

« on: May 19, 2021, 01:59:39 am »

Hey everyone! When I learned about _MEMSOUND by watching Fellippe's video on QB64 Team channel.. I had an
idea to visualise the sound...

REPLACE the value of file_name$ to your sound file.

Have fun!!

Code: QB64: [Select]

'#####################
' Music Visualiser 2D
' By Ashish
' 18 May, 2021
'#####################
 
file_name$ = "rolling.mp3" '<<---- replace with your file name with a sound file you have
$Let DEBUG = 1
 
$If DEBUG Then
    $Console
    _Echo "loading sound"
$End If
Dim song&
 
song& = _SndOpen(file_name$)
If song& = 0 Then Print "Load failed.": End
 
_Title "Music Visualiser 2D"
Type vec3
    As Single x, y, z
End Type
Type vec2
    As Single x, y
End Type
Declare Library
    Sub gluLookAt (ByVal eyeX#, Byval eyeY#, Byval eyeZ#, Byval centerX#, Byval centerY#, Byval centerZ#, Byval upX#, Byval upY#, Byval upZ#)
End Declare
Screen _NewImage(800, 600, 32)
Dim Shared leftChannel As _MEM, rightChannel As _MEM
Dim Shared stereo As _Byte, glAllow As _Byte
Dim Shared leftData(0 To 360) As Single, rightData(0 To 360) As Single, colorData(0 To 360) As vec3
Dim tmp_color As _Unsigned Long
For i = 0 To 360
    tmp_color = hsb~&(i * (255 / 360), 255, 128, 255)
    colorData(i).x = _Red(tmp_color) / 255
    colorData(i).y = _Green(tmp_color) / 255
    colorData(i).z = _Blue(tmp_color) / 255
Next
 
leftChannel = _MemSound(song&, 1)
rightChannel = _MemSound(song&, 2)
If leftChannel.SIZE = 0 Then
    Print "An error occurred."
    End
End If
If rightChannel.SIZE = 0 Then
    $If DEBUG Then
        _Echo "sound is mono"
    $End If
    stereo = 0
Else
    $If DEBUG Then
        _Echo "sound is stereo"
    $End If
    stereo = 1
End If
 
Dim i As _Offset, j As _Offset
i = 0
glAllow = 1
_FPS 60
_SndPlay song&
Do
 
 
 
    For n = 0 To 360
        _MemGet leftChannel, leftChannel.OFFSET + i + j, a1% 'get sound data
        leftData(n) = a1% * 0.00001
        If stereo = 1 Then
            _MemGet rightChannel, rightChannel.OFFSET + i + j, a2%
            rightData(n) = a2% * 0.00001
        End If
        j = j + 2
        If i + j + 2 > leftChannel.SIZE Then Exit Do
        If stereo = 1 And i + j + 2 > rightChannel.SIZE Then Exit Do
    Next
    i = i + 2 * (44100 / 60)
    j = 0
    If i + 2 > leftChannel.SIZE Then Exit Do
    If stereo = 1 And i + j + 2 > rightChannel.SIZE Then Exit Do
    _Limit 60
Loop
 
 
_SndClose song& 'closing the sound releases the mem blocks
 
Sub _GL ()
    Static glInit
    If glAllow = 0 Then
        Exit Sub
    End If
    If glInit = 0 Then
        glInit = 1
        _glViewport 0, 0, _Width, _Height
        $If DEBUG Then
            _Echo "_GL() : initialization done. glInit set to 1"
        $End If
    End If
 
    'projection setup
    _glMatrixMode _GL_PROJECTION
    _glLoadIdentity
    _gluPerspective 50, _Width / _Height, 0.1, 50
 
    _glMatrixMode _GL_MODELVIEW
    _glLoadIdentity
    gluLookAt 0, 0, 3, 0, 0, 0, 0, 1, 0
 
 
 
    _glBegin _GL_LINES
    For i = 0 To 360
        c = Int(map(Abs(leftData(i)), 0, 0.7, 0, 360))
        _glColor3f colorData(c).x, colorData(c).y, colorData(c).z
        _glVertex2f -1, 0
        _glVertex2f -1 + (0.5 + leftData(i)) * Cos(_D2R(i)), (0.5 + leftData(i)) * Sin(_D2R(i))
        _glVertex2f 1, 0
        If stereo = 0 Then
 
            _glVertex2f 1 + (0.5 + leftData(i)) * Cos(_D2R(i)), (0.5 + leftData(i)) * Sin(_D2R(i))
        Else
            _glVertex2f 1 + (0.5 + rightData(i)) * Cos(_D2R(i)), (0.5 + rightData(i)) * Sin(_D2R(i))
        End If
    Next
    _glEnd
    _glFlush
End Sub
 
 
'function from
'p5js.bas
'http://bit.ly/p5jsbas
Function map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
End Function
 
 
'method adapted form http://stackoverflow.com/questions/4106363/converting-rgb-to-hsb-colors
Function hsb~& (__H As _Float, __S As _Float, __B As _Float, A As _Float)
    Dim H As _Float, S As _Float, B As _Float
 
    H = map(__H, 0, 255, 0, 360)
    S = map(__S, 0, 255, 0, 1)
    B = map(__B, 0, 255, 0, 1)
 
    If S = 0 Then
        hsb~& = _RGBA32(B * 255, B * 255, B * 255, A)
        Exit Function
    End If
 
    Dim fmx As _Float, fmn As _Float
    Dim fmd As _Float, iSextant As Integer
    Dim imx As Integer, imd As Integer, imn As Integer
 
    If B > .5 Then
        fmx = B - (B * S) + S
        fmn = B + (B * S) - S
    Else
        fmx = B + (B * S)
        fmn = B - (B * S)
    End If
 
    iSextant = Int(H / 60)
 
    If H >= 300 Then
        H = H - 360
    End If
 
    H = H / 60
    H = H - (2 * Int(((iSextant + 1) Mod 6) / 2))
 
    If iSextant Mod 2 = 0 Then
        fmd = (H * (fmx - fmn)) + fmn
    Else
        fmd = fmn - (H * (fmx - fmn))
    End If
 
    imx = _Round(fmx * 255)
    imd = _Round(fmd * 255)
    imn = _Round(fmn * 255)
 
    Select Case Int(iSextant)
        Case 1
            hsb~& = _RGBA32(imd, imx, imn, A)
        Case 2
            hsb~& = _RGBA32(imn, imx, imd, A)
        Case 3
            hsb~& = _RGBA32(imn, imd, imx, A)
        Case 4
            hsb~& = _RGBA32(imd, imn, imx, A)
        Case 5
            hsb~& = _RGBA32(imx, imn, imd, A)
        Case Else
            hsb~& = _RGBA32(imx, imd, imn, A)
    End Select
 
End Function
 

Programs / Colorful Triangle Geometry

« on: May 04, 2021, 02:01:02 am »

Hi everyone!
I made a program which makes colorful and beautiful pattern full of triangles.
I hope you will like like it. :)

Code: QB64: [Select]

'Coded By Ashish
'4 may, 2021
'edited : 9 may,2021
_Title "Triangular Geometry"
Screen _NewImage(800, 600, 32)
Randomize Timer
404 pattern 400, 0, 0, 600, 800, 600, 600, Int(Rnd * 255), 50 + Int(Rnd * 205)
_Display
_Delay 0.25
GoTo 404
Sub pattern (x0, y0, x1, y1, x2, y2, d_max, s_min, s_width)
    mx = (x1 + x2) / 2: my = (y1 + y2) / 2
    d = Int(Sqr((mx - x0) ^ 2 + (my - y0) ^ 2))
    drawTriangleSolid x0, y0, x1, y1, x2, y2, hsb(map(d, 10, d_max, s_min, (s_max + s_width) Mod 255), 255, 128, map(d, 10, d_max, 50, 255))
    If d > 10 Then
        If d >= d_max Then
            pattern mx, my, x0, y0, x1, y1, d_max, s_min, s_width
            pattern mx, my, x0, y0, x2, y2, d_max, s_min, s_width
 
        Else
            If Rnd > 0.5 Then pattern mx, my, x0, y0, x1, y1, d_max, s_min, s_width Else pattern mx, my, x0, y0, x2, y2, d_max, s_min, s_width
        End If
    End If
End Sub
 
Sub drawTriangleSolid (x1, y1, x2, y2, x3, y3, c~&)
    Static temp_color_img As Long, drawTriangle_init As _Byte
    If drawTriangle_init = 0 Then
        temp_color_img = _NewImage(1, 1, 32)
        drawTriangle_init = 1
    End If
    preDest = _Dest
    _Dest temp_color_img
    PSet (0, 0), c~&
    _Dest preDest
 
    _MapTriangle (0, 0)-(0, 0)-(0, 0), temp_color_img To(x1, y1)-(x2, y2)-(x3, y3), 0, _Smooth
 
End Sub
 
Sub drawTriangle (x1, y1, x2, y2, x3, y3, c~&)
    Line (x1, y1)-(x2, y2), c~&
    Line (x2, y2)-(x3, y3), c~&
    Line (x3, y3)-(x1, y1), c~&
End Sub
 
'method adapted form http://stackoverflow.com/questions/4106363/converting-rgb-to-hsb-colors
Function hsb~& (__H As _Float, __S As _Float, __B As _Float, A As _Float)
    Dim H As _Float, S As _Float, B As _Float
 
    H = map(__H, 0, 255, 0, 360)
    S = map(__S, 0, 255, 0, 1)
    B = map(__B, 0, 255, 0, 1)
 
    If S = 0 Then
        hsb~& = _RGBA32(B * 255, B * 255, B * 255, A)
        Exit Function
    End If
 
    Dim fmx As _Float, fmn As _Float
    Dim fmd As _Float, iSextant As Integer
    Dim imx As Integer, imd As Integer, imn As Integer
 
    If B > .5 Then
        fmx = B - (B * S) + S
        fmn = B + (B * S) - S
    Else
        fmx = B + (B * S)
        fmn = B - (B * S)
    End If
 
    iSextant = Int(H / 60)
 
    If H >= 300 Then
        H = H - 360
    End If
 
    H = H / 60
    H = H - (2 * Int(((iSextant + 1) Mod 6) / 2))
 
    If iSextant Mod 2 = 0 Then
        fmd = (H * (fmx - fmn)) + fmn
    Else
        fmd = fmn - (H * (fmx - fmn))
    End If
 
    imx = _Round(fmx * 255)
    imd = _Round(fmd * 255)
    imn = _Round(fmn * 255)
 
    Select Case Int(iSextant)
        Case 1
            hsb~& = _RGBA32(imd, imx, imn, A)
        Case 2
            hsb~& = _RGBA32(imn, imx, imd, A)
        Case 3
            hsb~& = _RGBA32(imn, imd, imx, A)
        Case 4
            hsb~& = _RGBA32(imd, imn, imx, A)
        Case 5
            hsb~& = _RGBA32(imx, imn, imd, A)
        Case Else
            hsb~& = _RGBA32(imx, imd, imn, A)
    End Select
 
End Function
 
 
'from p5js.bas
Function map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
End Function
 
 

Programs / Pyramid with tile texture

« on: March 26, 2021, 10:25:51 am »

Hey everyone! I've a new opengl program for you!

Code: QB64: [Select]

_Title "Pyramid with tile texture"
'Coded by Ashish
'26 march, 2021
Screen _NewImage(600, 600, 32)
 
Type vec3
    As Single x, y, z
End Type
 
Declare Library
    'for camera
    Sub gluLookAt (ByVal eyeX#, Byval eyeY#, Byval eyeZ#, Byval centerX#, Byval centerY#, Byval centerZ#, Byval upX#, Byval upY#, Byval upZ#)
End Declare
 
 
Dim Shared glAllow As _Byte
Dim Shared texture_data As Long, pyramid_coord(3) As vec3, texcoord(2) As vec3
 
'coordinate data
pyramid_coord(0).x = 0: pyramid_coord(0).y = 2: pyramid_coord(0).z = 0
pyramid_coord(1).x = -2: pyramid_coord(1).y = -2: pyramid_coord(1).z = -2
pyramid_coord(2).x = 2: pyramid_coord(2).y = -2: pyramid_coord(2).z = -2
pyramid_coord(3).x = 0: pyramid_coord(3).y = -2: pyramid_coord(3).z = 2
texcoord(0).x = 0: texcoord(0).y = 0
texcoord(1).x = 0.5: texcoord(1).y = 1
texcoord(2).x = 1: texcoord(2).y = 0
 
texture_data = _NewImage(400, 400, 32)
texture_data_r = _CopyImage(texture_data)
glAllow = 1
'set these shades values as per your requirement
shade1& = _RGB(15, 190, 200)
shade2& = _RGB(240, 10, 70)
Do
    _Dest texture_data_r
    Line (0, 0)-(_Width(texture_data_r), _Height(texture_data_r)), shade1&, BF
    i = 1
    For y = 0 To _Height(texture_data_r) Step 40
        i = i * -1
        For x = -40 + 20 * i To _Width(texture_data_r) + 40 Step 80
            CircleFill x + offx, y, 20, shade2&
        Next
    Next
    offx = offx + 3
    If offx > 80 Then offx = 0
    _Dest 0
    _PutImage , texture_data_r, texture_data
    Cls , shade1&
    For x = -100 To 700 Step 100
        Line (x + ax, 0)-(x + ax, 700), shade2&
        Line (x + ax + 50, 0)-(x + ax + 50, 700), shade2&
        Paint (x + ax + 49, 0), shade2&, shade2&
        Paint (x + ax + 1, 0), shade2&, shade2&
    Next
    If ax > 100 Then ax = 0
    ax = ax + 2
    _Limit 60
    _Display
Loop
 
Sub _GL ()
    If glAllow = 0 Then Exit Sub
    Static glInit, tex As Long, m As _MEM, t
    If glInit = 0 Then
        glInit = 1
        _glViewport 0, 0, _Width, _Height
        'texture
        _glGenTextures 1, _Offset(tex)
        m = _MemImage(texture_data)
 
    End If
 
    _glEnable _GL_TEXTURE_2D
    _glEnable _GL_DEPTH_TEST
    _glEnable _GL_BLEND
 
    'projection settings
    _glMatrixMode _GL_PROJECTION
    _gluPerspective 60, _Width / _Height, 0.1, 10
 
    _glMatrixMode _GL_MODELVIEW
    _glLoadIdentity
    gluLookAt 0, 0, 6, 0, 0, 0, 0, 1, 0
    _glRotatef t, 0, 1, 0.8
 
    'drawing pyramid
    _glBindTexture _GL_TEXTURE_2D, tex
    _glTexImage2D _GL_TEXTURE_2D, 0, _GL_RGB, _Width(texture_data), _Height(texture_data), 0, _GL_BGRA_EXT, _GL_UNSIGNED_BYTE, m.OFFSET
    _glTexParameteri _GL_TEXTURE_2D, _GL_TEXTURE_MAG_FILTER, _GL_LINEAR
    _glTexParameteri _GL_TEXTURE_2D, _GL_TEXTURE_MIN_FILTER, _GL_NEAREST
 
    For i = 0 To 3
        _glBegin _GL_TRIANGLES
        For j = i To i + 2
            _glTexCoord2f texcoord(j Mod 3).x, texcoord(j Mod 3).y
            _glVertex3f pyramid_coord(j Mod 4).x, pyramid_coord(j Mod 4).y, pyramid_coord(j Mod 4).z
        Next
        _glEnd
    Next
    t = t + 1
End Sub
 
 
Sub CircleFill (x As Long, y As Long, R As Long, C As _Unsigned Long)
    Dim x0 As Single, y0 As Single
    Dim e As Single
 
    x0 = R
    y0 = 0
    e = -R
    Do While y0 < x0
        If e <= 0 Then
            y0 = y0 + 1
            Line (x - x0, y + y0)-(x + x0, y + y0), C, BF
            Line (x - x0, y - y0)-(x + x0, y - y0), C, BF
            e = e + 2 * y0
        Else
            Line (x - y0, y - x0)-(x + y0, y - x0), C, BF
            Line (x - y0, y + x0)-(x + y0, y + x0), C, BF
            x0 = x0 - 1
            e = e - 2 * x0
        End If
    Loop
    Line (x - R, y)-(x + R, y), C, BF
End Sub
 
 
 

Programs / NEON PEN

« on: November 19, 2020, 09:53:19 am »

INSTRUCTION : Drag with mouse on screen to draw stuff. :)

Code: QB64: [Select]

_TITLE "NEON PEN"
SCREEN _NEWIMAGE(800, 600, 32)
 
TYPE vec2
    x AS SINGLE
    y AS SINGLE
END TYPE
 
REDIM SHARED vert(1024) AS vec2, max_v_index
DIM SHARED rFactor!, gFactor!, bFactor!
rFactor! = 0.5: gFactor! = 1: bFactor! = 0.5
DO
    CLS
    PRINT "VRAM Usage : "; vram; "KB"
    PRINT "Vertices Used : "; max_v_index; "/"; UBOUND(vert)
    vram = (UBOUND(vert) * 4) / 1024
    WHILE _MOUSEINPUT: WEND
    IF _MOUSEBUTTON(1) THEN
        mx = _MOUSEX: my = _MOUSEY
        px = mx: py = my
        WHILE _MOUSEBUTTON(1) AND max_v_index < UBOUND(vert)
            WHILE _MOUSEINPUT: WEND
            mx = _MOUSEX: my = _MOUSEY
            IF ABS(px - mx) >= ABS(py - my) THEN
                IF mx >= px THEN s = 1 ELSE s = -1
                FOR i = px TO mx STEP s
                    vert(max_v_index).x = i
                    vert(max_v_index).y = map(i, px, mx, py, my)
                    max_v_index = max_v_index + 1
                    IF max_v_index > INT(UBOUND(vert) * 0.8) THEN REDIM _PRESERVE vert(max_v_index * 2) AS vec2
                NEXT
            ELSE
                IF my >= py THEN s = 1 ELSE s = -1
                FOR i = py TO my STEP s
                    vert(max_v_index).x = map(i, py, my, px, mx)
                    vert(max_v_index).y = i
                    max_v_index = max_v_index + 1
                    IF max_v_index > INT(UBOUND(vert) * 0.8) THEN REDIM _PRESERVE vert(max_v_index * 2) AS vec2
                NEXT
 
            END IF
            px = mx: py = my
            _LIMIT 30
        WEND
    END IF
 
    _LIMIT 60
LOOP
 
SUB _GL ()
    STATIC glInit
    IF glInit = 0 THEN
        glInit = 1
 
    END IF
    _glViewport 0, 0, _WIDTH, _HEIGHT
    'set the gl screen so that it can work normal screen coordinates
    _glTranslatef -1, 1, 0
    _glScalef 1 / 400, -1 / 300, 1
 
    _glEnable _GL_BLEND
 
    _glBlendFunc _GL_SRC_ALPHA, _GL_ONE
    _glEnableClientState _GL_VERTEX_ARRAY
    _glVertexPointer 2, _GL_FLOAT, 0, _OFFSET(vert())
    FOR j = 1 TO 15
        _glColor4f rFactor!, gFactor!, bFactor!, 0.015
        _glPointSize j
        _glDrawArrays _GL_POINTS, 10, max_v_index
    NEXT
    _glFlush
END SUB
 
FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION
 
 

Thank you for running it. :)

EDIT : CODE UPDATED. Thanks to @Dav for finding a glitch in which it stopped drawing sometimes (when both max_v_index equal to Ubound(vert) )

Programs / Re: poem generator

« on: July 18, 2020, 05:33:28 am »

Note: This message is awaiting approval by a moderator.

Nice! :)

Programs / COVID-19 in QB64

« on: June 01, 2020, 03:56:30 am »

WARNING : Use mask. Sanitize your hands after closing the program.

Code: QB64: [Select]

'COVID-19 in QB64
'By Ashish
'1 Jun, 2020
'
'WARNING:Use mask. Apply santizer after closing the program.
 
_TITLE "I'm Covid-19"
SCREEN _NEWIMAGE(600, 600, 32)
 
DECLARE LIBRARY
    SUB glutSolidSphere (BYVAL radius AS DOUBLE, BYVAL slices AS LONG, BYVAL stack AS LONG)
    SUB gluLookAt (BYVAL eyeX#, BYVAL eyeY#, BYVAL eyeZ#, BYVAL centerX#, BYVAL centerY#, BYVAL centerZ#, BYVAL upX#, BYVAL upY#, BYVAL upZ#)
 
END DECLARE
 
DIM SHARED glAllow AS _BYTE
TYPE vec3
    x AS SINGLE
    y AS SINGLE
    z AS SINGLE
END TYPE
 
TYPE COVID19
    pos AS vec3
    r AS SINGLE
END TYPE
 
DIM SHARED virus AS COVID19
 
virus.r = 0.3
 
glAllow = -1
DO
    _LIMIT 1
LOOP
 
SUB _GL ()
    STATIC init, aspect, rotY
 
    IF glAllow = 0 THEN EXIT SUB
    IF init = 0 THEN
        init = 1
        aspect = _WIDTH / _HEIGHT
        _glViewport 0, 0, _WIDTH, _HEIGHT
    END IF
 
    _glEnable _GL_DEPTH_TEST
    _glEnable _GL_LIGHTING
    _glEnable _GL_LIGHT0
 
    _glLightfv _GL_LIGHT0, _GL_AMBIENT, glVec4(0.0, 0.0, 0.0, 1)
    _glLightfv _GL_LIGHT0, _GL_DIFFUSE, glVec4(0.8, 0.8, 0.8, 1)
    _glLightfv _GL_LIGHT0, _GL_SPECULAR, glVec4(1, 1, 1, 1)
    _glLightfv _GL_LIGHT0, _GL_POSITION, glVec4(0, 0, 10, 1)
 
 
 
    _glMatrixMode _GL_PROJECTION
    _gluPerspective 50, aspect, 0.1, 10
 
    _glMatrixMode _GL_MODELVIEW
    gluLookAt 0, 0, 2, 0, 0, 0, 0, 1, 0
 
 
    _glLineWidth 2.0
    _glPointSize 10.0
 
    _glTranslatef virus.pos.x, virus.pos.y, virus.pos.z
    _glRotatef rotY, 0.5, 1, 0
    rotY = rotY + 1
 
    _glMaterialfv _GL_FRONT_AND_BACK, _GL_DIFFUSE, glVec4(0, 0.9, 0, 1)
 
    glutSolidSphere virus.r, 20, 20
 
    _glDisable _GL_LIGHTING
    _glColor3f 1, 0, 0
    _glBegin _GL_LINES
    FOR phi = 0.4 TO _PI(2) STEP .5
        FOR theta = 0.3 TO _PI STEP .5
            _glVertex3f virus.r * SIN(theta) * COS(phi), virus.r * SIN(theta) * SIN(phi), virus.r * COS(theta)
            _glVertex3f (0.1 + virus.r) * SIN(theta) * COS(phi), (0.1 + virus.r) * SIN(theta) * SIN(phi), (0.1 + virus.r) * COS(theta)
        NEXT
    NEXT
    _glEnd
    _glBegin _GL_POINTS
    FOR phi = 0.4 TO _PI(2) STEP .5
        FOR theta = 0.3 TO _PI STEP .5
            _glVertex3f (0.1 + virus.r) * SIN(theta) * COS(phi), (0.1 + virus.r) * SIN(theta) * SIN(phi), (0.1 + virus.r) * COS(theta)
        NEXT
    NEXT
    _glEnd
    _glEnable _GL_LIGHTING
 
 
END SUB
 
 
FUNCTION glVec4%& (x, y, z, w) 'give the offset of the given vector
    STATIC internal_vec4(3)
    internal_vec4(0) = x
    internal_vec4(1) = y
    internal_vec4(2) = z
    internal_vec4(3) = w
    glVec4%& = _OFFSET(internal_vec4())
END FUNCTION
 

Programs / Space Filling with Polygons

« on: April 28, 2020, 07:42:44 am »

Hey everyone!

This program fills the space with a polygon (triangles, squares, etc) in such a way that any two polygon must not overlap/collide.
The polygon size gradually reduces and it try to fill as much space as possible.
The color of polygon also changes gradually, resulting in a beautiful pattern. :)

I took some help for concepts behind this from here - http://paulbourke.net/fractals/randomtile/

Run the program & Enjoy.

Instruction : Enter the number of sides of the polygon you want to fill with (of course, it must greater than 2). Higher values will result
in slow speed. :)

Code: QB64: [Select]

'Space Filling with Polygon
'By Ashish
 
RANDOMIZE TIMER
TYPE XY
    x AS SINGLE
    y AS SINGLE
END TYPE
 
_TITLE "Space Filling with Polygon"
SCREEN _NEWIMAGE(800, 600, 32)
 
INPUT "Enter the number of side for a polygon (must be greater than 2) : ", x%
IF x% < 3 THEN PRINT "It must be greate than 2!, taking default value of 3. Hit ENTER.": SLEEP: x% = 3
polySides = x%
DIM tempPoly1(polySides - 1) AS XY, tempPoly2(polySides - 1) AS XY
REDIM polys(polySides - 1) AS XY
 
 
init = 0
poly_index = 0
i = 1
c = 1.1
failed = 0
CLS
DO
    IF init = 0 THEN
        r = p5random(150, 200)
        ox = p5random(r, _WIDTH - r)
        oy = p5random(r, _HEIGHT - r)
        offAng = p5random(-_PI, _PI)
        FOR j = 0 TO polySides - 1
            polys(j).x = ox + COS(j * (_PI(2 / polySides)) + offAng) * r
            polys(j).y = oy + SIN(j * (_PI(2 / polySides)) + offAng) * r
        NEXT
        clr~& = midColor(_RGB(255, 255, 0), _RGB(255, 100, 0), map(r, 200, 3, 0, 1))
        drawPoly polys(), clr~&
        init = 1
        poly_index = poly_index + polySides
    ELSE
        r = 200 / (c ^ i)
        ox = p5random(r, _WIDTH - r)
        oy = p5random(r, _HEIGHT - r)
        collided = 0
        offAng = p5random(-_PI, _PI)
        FOR j = 0 TO polySides - 1
            tempPoly1(j).x = ox + COS(j * (_PI(2 / polySides)) + offAng) * r
            tempPoly1(j).y = oy + SIN(j * (_PI(2 / polySides)) + offAng) * r
        NEXT
        FOR j = 0 TO UBOUND(polys) STEP polySides
            FOR k = j TO j + polySides - 1
                tempPoly2(k - j) = polys(k)
            NEXT
            IF polyCollide(tempPoly1(), tempPoly2()) THEN collided = -1: EXIT FOR
        NEXT
        IF NOT collided THEN
            ' _echo "yes"
            REDIM _PRESERVE polys(UBOUND(polys) + polySides) AS XY
            FOR j = poly_index TO poly_index + polySides - 1
                polys(j) = tempPoly1(j - poly_index)
            NEXT
            clr~& = midColor(_RGB(255, 255, 0), _RGB(255, 100, 0), map(r, 200, 3, 0, 1))
            drawPoly tempPoly1(), clr~&
            poly_index = poly_index + polySides
        ELSE
            failed = failed + 1
            IF failed > (i * 60) THEN i = i + 1: failed = 0
        END IF
    END IF
LOOP UNTIL r < 3
 
FUNCTION midColor~& (clr1 AS _UNSIGNED LONG, clr2 AS _UNSIGNED LONG, v)
    midColor~& = _RGB(map(v, 0, 1, _RED(clr1), _RED(clr2)), map(v, 0, 1, _GREEN(clr1), _GREEN(clr2)), map(v, 0, 1, _BLUE(clr1), _BLUE(clr2)))
END FUNCTION
 
SUB drawPoly (vert() AS XY, clr AS _UNSIGNED LONG)
    n = UBOUND(vert)
    DIM cx, cy
    FOR i = 0 TO n
        LINE (vert(i).x, vert(i).y)-(vert((i + 1) MOD (n + 1)).x, vert((i + 1) MOD (n + 1)).y), clr
        cx = cx + vert(i).x: cy = cy + vert(i).y
    NEXT
    cx = cx / (n + 1): cy = cy / (n + 1)
    PAINT (cx, cy), clr, clr
END SUB
 
 
FUNCTION polyCollide (vert1() AS XY, vert2() AS XY)
    DIM n1 AS INTEGER, n2 AS INTEGER
    n1 = UBOUND(vert1): n2 = UBOUND(vert2)
    'checking if any point of polygon 1 inside polygon 2
    FOR i = 0 TO n1
        IF pointInsidePoly(vert1(i), vert2()) THEN polyCollide = -1: EXIT FUNCTION 
    NEXT
    'checking if any point of polygon 2 inside polygon 1
    FOR i = 0 TO n2
        IF pointInsidePoly(vert2(i), vert1()) THEN polyCollide = -1: EXIT FUNCTION
    NEXT
    ' checking the edge intersection
    FOR i = 0 TO n1
        FOR j = 0 TO n2
            IF lineIntersect(vert1(i).x, vert1(i).y, vert1((i + 1) MOD (n1 + 1)).x, vert1((i + 1) MOD (n1 + 1)).y, vert2(j).x, vert2(j).y, vert2((j + 1) MOD (n2 + 1)).x, vert2((j + 1) MOD (n2 + 1)).y) THEN polyCollide = -1: EXIT FUNCTION
        NEXT
    NEXT
END FUNCTION
 
'from paulbourke.net
FUNCTION pointInsidePoly (p AS XY, polyVert() AS XY)
    DIM ax1, ax2, ay1, ay2
    n = UBOUND(polyVert)
    FOR i = 0 TO n
        ax1 = polyVert(i).x - p.x
        ay1 = polyVert(i).y - p.y
        ax2 = polyVert((i + 1) MOD (n + 1)).x - p.x
        ay2 = polyVert((i + 1) MOD (n + 1)).y - p.y
        ang = ang + angle2D(ax1, ay1, ax2, ay2)
    NEXT
    pointInsidePoly = (ABS(ang) >= _PI)
END FUNCTION
 
'from paulbourke.net
FUNCTION angle2D (x1, y1, x2, y2)
    DIM theta1, theta2, ftheta
    theta1 = _ATAN2(y1, x1)
    theta2 = _ATAN2(y2, x2)
    ftheta = theta1 - theta2
    WHILE ftheta > _PI: ftheta = ftheta - _PI(2): WEND
    WHILE ftheta < -_PI: ftheta = ftheta + _PI(2): WEND
    angle2D = ftheta
END FUNCTION
 
FUNCTION lineIntersect (__x1, __y1, __x2, __y2, __x3, __y3, __x4, __y4)
    DIM x1 AS INTEGER, y1 AS INTEGER, x2 AS INTEGER, y2 AS INTEGER, x3 AS INTEGER, y3 AS INTEGER, x4 AS INTEGER, y4 AS INTEGER
    DIM a1, b1, c1, a2, b2, c2
    DIM a1b2_minus_a2b1, b1c2_minus_b2c1, a2c1_minus_a1c2
    DIM inter_x AS INTEGER, inter_y AS INTEGER
 
    x1 = __x1: x2 = __x2: x3 = __x3: x4 = __x4
    y1 = __y1: y2 = __y2: y3 = __y3: y4 = __y4
    
    IF x1 > x2 THEN SWAP x1, x2
    IF x3 > x4 THEN SWAP x3, x4
    IF y1 > y2 THEN SWAP y1, y2
    IF y3 > y4 THEN SWAP y3, y4
    
    a1 = __y2 - __y1: b1 = -(__x2 - __x1): c1 = (__x2 * __y1) - (__x1 * __y2)
    a2 = __y4 - __y3: b2 = -(__x4 - __x3): c2 = (__x4 * __y3) - (__x3 * __y4)
 
    'check if lines are perfectly vertical or horizontal
    IF a1 = 0 AND a2 = 0 THEN lineIntersect = (__y1 = __y3): _DEST 0: EXIT FUNCTION
    IF b1 = 0 AND b2 = 0 THEN lineIntersect = (__x1 = __x3): _DEST 0: EXIT FUNCTION
    IF a2 = 0 OR b2 = 0 THEN GOTO skip_component_ratio
    
    'check if the whole line segments coincide with each other.
    IF c2 <> 0 THEN
        IF (a1 / a2) = (b1 / b2) AND (b1 / b2) = (c1 / c2) THEN
            lineIntersect = -1: EXIT FUNCTION
        END IF
    END IF
    skip_component_ratio:
    'check if the line segments have same slope.
    IF a1 * b2 = a2 * b1 THEN
        lineIntersect = (c1 = c2) 'special case, when they still coincide (as c1=c2)
        EXIT FUNCTION
    END IF
    'check if the line do intersect between the segments.
    a1b2_minus_a2b1 = (a1 * b2) - (a2 * b1): b1c2_minus_b2c1 = (b1 * c2) - (b2 * c1): a2c1_minus_a1c2 = (a2 * c1) - (a1 * c2)
    inter_x = b1c2_minus_b2c1 / a1b2_minus_a2b1: inter_y = a2c1_minus_a1c2 / a1b2_minus_a2b1
    
    lineIntersect = ((inter_x >= x1 AND inter_x <= x2 AND inter_y >= y1 AND inter_y <= y2)) and ((inter_x >= x3 AND inter_x <= x4 AND inter_y >= y3 AND inter_y <= y4))
END FUNCTION
 
'taken from p5js.bas
FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION
 
FUNCTION p5random! (mn!, mx!)
    IF mn! > mx! THEN
        SWAP mn!, mx!
    END IF
    p5random! = RND * (mx! - mn!) + mn!
END FUNCTION
 

Program output for the input value of 3, i.e. for a triangle.

Programs / AI : Digit Recognizer

« on: April 13, 2020, 10:01:42 am »

Hi everyone! I have been working on this program for a while.. I decided to share with you.
What does the program do?
You have to SLOWLY draw number with single stroke. The program will try to guess what number wrote.
It will work great if you have awesome handwriting!!

The program can not run without "trained files". Yes, it was made it to learn.

The attachment contain the required files along with the source code. Please make sure that the "trained files" are in the same directory
with the source code.

Download the zip from attachment.

Here are some of the screenshots of running program -

Programs / Re: a test or experiment in epidemiology

« on: March 24, 2020, 05:09:55 am »

Note: This message is awaiting approval by a moderator.

According to your program, it will take 32 days to end people around 7 billion.
Quite dangerous.

Programs / Re: Time/Date Functions

« on: March 23, 2020, 08:45:28 am »

Note: This message is awaiting approval by a moderator.

Hi! It runs fine.

Programs / Re: Not again! Another Time Piece

« on: March 16, 2020, 07:21:05 am »

Note: This message is awaiting approval by a moderator.

Oh WOW! I never knew that last digit of Fibonacci had any pattern.

Programs / 3D Graph Plotter

« on: March 13, 2020, 07:02:50 am »

Hi everyone!
This program input the expression for Z = something and plot the graph in 3D "something" consist of terms having X and Z variables or constant. For example X+Y or X+Y*5 + 10, etc. It even support trigonometric functions.

Thanks to @STxAxTIC and @FellippeHeitor

Controls : Click & Drag on screen with mouse for rotation.

Note : You need to download additional sxript.bi & sxript.bm from attachment.

EDIT: Code updated. Now, it accept expression for Z = ... which is generally accepted.

Code: QB64: [Select]

'##############################################################################################
'3D Grapher By Ashish Kushwaha
'----------------------------------------------------------------------------------------------
'* Thanks to STxAxTIC. Without his sxript, coding this would be harder.
'* Thanks to FellipeHeitor. His INPUTBOX() come handy when I need QB64 Input & OpenGL together.
'----------------------------------------------------------------------------------------------
'Description: Give an expression for z = ... containing terms of x, y (any power) & constants
'With the power of sxript, it also support *trigonometric functions* in the expression.
'Click on Ok. Then the Graph is plotted in 3D Space & shown in 2D screen.
'Drag on screen with mouse for rotation.
'----------------------------------------------------------------------------------------------
'Friday the 13th, 2020
 
'$INCLUDE:'sxript.bi'
 
DECLARE LIBRARY
    SUB gluLookAt (BYVAL eyeX#, BYVAL eyeY#, BYVAL eyeZ#, BYVAL centerX#, BYVAL centerY#, BYVAL centerZ#, BYVAL upX#, BYVAL upY#, BYVAL upZ#)
END DECLARE
 
 
_TITLE "3D Grapher"
SCREEN _NEWIMAGE(600, 600, 32)
 
dummy = INPUTBOX("Enter the expression for Z = ", "Enter the expression for Z = (ex. X*Y)", "X+Y-1", e$, -1)
IF dummy = 2 THEN SYSTEM
CLS
PRINT "Generating... Just a moment"
_DISPLAY
TYPE rgb
    r AS SINGLE
    g AS SINGLE
    b AS SINGLE
END TYPE
DIM SHARED vert(100, 100), glAllow, xRot, yRot, colArr(100, 100) AS rgb
 
FOR x = -50 TO 50
    FOR z = -50 TO 50
        expression$ = ""
        FOR i = 1 TO LEN(e$)
            ca$ = MID$(e$, i, 1)
            IF LCASE$(ca$) = "x" THEN ca$ = _TRIM$(STR$(x / 10))
            IF LCASE$(ca$) = "y" THEN ca$ = _TRIM$(STR$(z / 10))
            expression$ = expression$ + ca$
        NEXT
        vert(x + 50, z + 50) = VAL(SxriptEval(expression$))
        'PRINT expression$, VAL(SxriptEval(expression$))
        'SLEEP
        c~& = hsb(map(z, -50, 50, 0, 255), 255, 128, 255)
        colArr(x + 50, z + 50).r = _RED(c~&) / 255
        colArr(x + 50, z + 50).g = _GREEN(c~&) / 255
        colArr(x + 50, z + 50).b = _BLUE(c~&) / 255
    NEXT
NEXT
_GLRENDER _ONTOP
glAllow = 1
'SLEEP
DO
    WHILE _MOUSEINPUT: WEND
    IF _MOUSEBUTTON(1) THEN
        x = _MOUSEX: y = _MOUSEY
        WHILE _MOUSEBUTTON(1)
            WHILE _MOUSEINPUT: WEND
            yRot = yRot + (_MOUSEX - x)
            xRot = xRot + (_MOUSEY - y)
            x = _MOUSEX: y = _MOUSEY
        WEND
    END IF
    _LIMIT 60
LOOP
 
SUB _GL () STATIC
    IF glAllow = 0 THEN EXIT SUB
 
    _glClear _GL_COLOR_BUFFER_BIT OR _GL_DEPTH_BUFFER_BIT
    _glEnable _GL_DEPTH_TEST
    _glEnable _GL_BLEND
 
 
    _glMatrixMode _GL_PROJECTION
    _gluPerspective 50, 1, 0.1, 40
 
    _glMatrixMode _GL_MODELVIEW
    _glLoadIdentity
 
    gluLookAt 0, 7, 15, 0, 0, 0, 0, 1, 0
    _glRotatef xRot, 1, 0, 0
    _glRotatef yRot, 0, 1, 0
    _glLineWidth 2.0
    'draw axis
    _glBegin _GL_LINES
    'x-axis
    _glColor3f 1, 0, 0
    _glVertex3f -5, 0, 0
    _glVertex3f 5, 0, 0
    'z-axis
    _glColor3f 0, 1, 0
    _glVertex3f 0, -5, 0
    _glVertex3f 0, 5, 0
    'y-axis
    _glColor3f 0, 0, 1
    _glVertex3f 0, 0, -5
    _glVertex3f 0, 0, 5
 
    _glEnd
    _glColor3f 1, 1, 1
    _glLineWidth 1.0
    FOR z = -50 TO 49
        _glBegin _GL_TRIANGLE_STRIP
        FOR x = -50 TO 50
            _glColor4f colArr(x + 50, z + 50).r, colArr(x + 50, z + 50).g, colArr(x + 50, z + 50).b, 0.7
            _glVertex3f map(x, -50, 50, -5, 5), vert(x + 50, z + 50), map(z, -50, 50, 5, -5)
            _glVertex3f map(x, -50, 50, -5, 5), vert(x + 50, z + 51), map(z + 1, -50, 50, 5, -5)
        NEXT
        _glEnd
    NEXT
 
 
END SUB
 
'By Fellipe Heitor
FUNCTION INPUTBOX (tTitle$, tMessage$, InitialValue AS STRING, NewValue AS STRING, Selected)
    'INPUTBOX ---------------------------------------------------------------------
    'Show a dialog and allow user input. Returns 1 = OK or 2 = Cancel.            '
    '                                                                             '
    '- tTitle$ is the desired dialog title. If not provided, it'll be "Input"     '
    '                                                                             '
    '- tMessage$ is the prompt that'll be shown to the user. You can show         '
    '   a multiline message by adding line breaks with CHR$(10).                  '
    '                                                                             '
    ' - InitialValue can be passed both as a string literal or as a variable.     '
    '                                                                             '
    '- Actual user input is returned by altering NewValue, so it must be          '
    '   passed as a variable.                                                     '
    '                                                                             '
    '- Selected indicates wheter the initial value will be preselected when the   '
    '   dialog is first shown. -1 preselects the whole text; positive values      '
    '   select only part of the initial value (from the character position passed '
    '   to the end of the initial value).                                         '
    '                                                                             '
    'Intended for use with 32-bit screen modes.                                   '
    '------------------------------------------------------------------------------
 
    'Variable declaration:
    DIM Message$, Title$, CharW AS INTEGER, MaxLen AS INTEGER
    DIM lineBreak AS INTEGER, totalLines AS INTEGER, prevlinebreak AS INTEGER
    DIM Cursor AS INTEGER, Selection.Start AS INTEGER, InputViewStart AS INTEGER
    DIM FieldArea AS INTEGER, DialogH AS INTEGER, DialogW AS INTEGER
    DIM DialogX AS INTEGER, DialogY AS INTEGER, InputField.X AS INTEGER
    DIM TotalButtons AS INTEGER, B AS INTEGER, ButtonLine$
    DIM cb AS INTEGER, DIALOGRESULT AS INTEGER, i AS INTEGER
    DIM message.X AS INTEGER, SetCursor#, cursorBlink%
    DIM DefaultButton AS INTEGER, k AS LONG
    DIM shiftDown AS _BYTE, ctrlDown AS _BYTE, Clip$
    DIM FindLF%, s1 AS INTEGER, s2 AS INTEGER
    DIM Selection.Value$
    DIM prevCursor AS INTEGER, ss1 AS INTEGER, ss2 AS INTEGER, mb AS _BYTE
    DIM mx AS INTEGER, my AS INTEGER, nmx AS INTEGER, nmy AS INTEGER
    DIM FGColor AS LONG, BGColor AS LONG
 
    'Data type used for the dialog buttons:
    TYPE BUTTONSTYPE
        ID AS LONG
        CAPTION AS STRING * 120
        X AS INTEGER
        Y AS INTEGER
        W AS INTEGER
    END TYPE
 
    'Color constants. You can customize colors by changing these:
    CONST TitleBarColor = _RGB32(0, 178, 179)
    CONST DialogBGColor = _RGB32(255, 255, 255)
    CONST TitleBarTextColor = _RGB32(0, 0, 0)
    CONST DialogTextColor = _RGB32(0, 0, 0)
    CONST InputFieldColor = _RGB32(200, 200, 200)
    CONST InputFieldTextColor = _RGB32(0, 0, 0)
    CONST SelectionColor = _RGBA32(127, 127, 127, 100)
 
    'Initial variable setup:
    Message$ = tMessage$
    Title$ = RTRIM$(LTRIM$(tTitle$))
    IF Title$ = "" THEN Title$ = "Input"
    NewValue = RTRIM$(LTRIM$(InitialValue))
    DefaultButton = 1
 
    'Save the current drawing page so it can be restored later:
    FGColor = _DEFAULTCOLOR
    BGColor = _BACKGROUNDCOLOR
    PCOPY 0, 1
 
    'Figure out the print width of a single character (in case user has a custom font applied)
    CharW = _PRINTWIDTH("_")
 
    'Place a color overlay over the old screen image so the focus is on the dialog:
    LINE (0, 0)-STEP(_WIDTH - 1, _HEIGHT - 1), _RGBA32(170, 170, 170, 170), BF
 
    'Message breakdown, in case CHR$(10) was used as line break:
    REDIM MessageLines(1) AS STRING
    MaxLen = 1
    DO
        lineBreak = INSTR(lineBreak + 1, Message$, CHR$(10))
        IF lineBreak = 0 AND totalLines = 0 THEN
            totalLines = 1
            MessageLines(1) = Message$
            MaxLen = LEN(Message$)
            EXIT DO
        ELSEIF lineBreak = 0 AND totalLines > 0 THEN
            totalLines = totalLines + 1
            REDIM _PRESERVE MessageLines(1 TO totalLines) AS STRING
            MessageLines(totalLines) = RIGHT$(Message$, LEN(Message$) - prevlinebreak + 1)
            IF LEN(MessageLines(totalLines)) > MaxLen THEN MaxLen = LEN(MessageLines(totalLines))
            EXIT DO
        END IF
        IF totalLines = 0 THEN prevlinebreak = 1
        totalLines = totalLines + 1
        REDIM _PRESERVE MessageLines(1 TO totalLines) AS STRING
        MessageLines(totalLines) = MID$(Message$, prevlinebreak, lineBreak - prevlinebreak)
        IF LEN(MessageLines(totalLines)) > MaxLen THEN MaxLen = LEN(MessageLines(totalLines))
        prevlinebreak = lineBreak + 1
    LOOP
 
    Cursor = LEN(NewValue)
    Selection.Start = 0
    InputViewStart = 1
    FieldArea = _WIDTH \ CharW - 4
    IF FieldArea > 62 THEN FieldArea = 62
    IF Selected > 0 THEN Selection.Start = Selected: Selected = -1
 
    'Calculate dialog dimensions and print coordinates:
    DialogH = _FONTHEIGHT * (6 + totalLines) + 10
    DialogW = (CharW * FieldArea) + 10
    IF DialogW < MaxLen * CharW + 10 THEN DialogW = MaxLen * CharW + 10
 
    DialogX = _WIDTH / 2 - DialogW / 2
    DialogY = _HEIGHT / 2 - DialogH / 2
    InputField.X = (DialogX + (DialogW / 2)) - (((FieldArea * CharW) - 10) / 2) - 4
 
    'Calculate button's print coordinates:
    TotalButtons = 2
    DIM Buttons(1 TO TotalButtons) AS BUTTONSTYPE
    B = 1
    Buttons(B).ID = 1: Buttons(B).CAPTION = "< OK >": B = B + 1
    Buttons(B).ID = 2: Buttons(B).CAPTION = "< Cancel >": B = B + 1
    ButtonLine$ = " "
    FOR cb = 1 TO TotalButtons
        ButtonLine$ = ButtonLine$ + RTRIM$(LTRIM$(Buttons(cb).CAPTION)) + " "
        Buttons(cb).Y = DialogY + 5 + _FONTHEIGHT * (5 + totalLines)
        Buttons(cb).W = _PRINTWIDTH(RTRIM$(LTRIM$(Buttons(cb).CAPTION)))
    NEXT cb
    Buttons(1).X = _WIDTH / 2 - _PRINTWIDTH(ButtonLine$) / 2
    FOR cb = 2 TO TotalButtons
        Buttons(cb).X = Buttons(1).X + _PRINTWIDTH(SPACE$(INSTR(ButtonLine$, RTRIM$(LTRIM$(Buttons(cb).CAPTION)))))
    NEXT cb
 
    'Main loop:
    DIALOGRESULT = 0
    _KEYCLEAR
    DO: _LIMIT 500
        'Draw the dialog.
        LINE (DialogX, DialogY)-STEP(DialogW - 1, DialogH - 1), DialogBGColor, BF
        LINE (DialogX, DialogY)-STEP(DialogW - 1, _FONTHEIGHT + 1), TitleBarColor, BF
        COLOR TitleBarTextColor
        _PRINTSTRING (_WIDTH / 2 - _PRINTWIDTH(Title$) / 2, DialogY + 1), Title$
 
        COLOR DialogTextColor, _RGBA32(0, 0, 0, 0)
        FOR i = 1 TO totalLines
            message.X = _WIDTH / 2 - _PRINTWIDTH(MessageLines(i)) / 2
            _PRINTSTRING (message.X, DialogY + 5 + _FONTHEIGHT * (i + 1)), MessageLines(i)
        NEXT i
 
        'Draw the input field
        LINE (InputField.X - 2, DialogY + 3 + _FONTHEIGHT * (3 + totalLines))-STEP(FieldArea * CharW, _FONTHEIGHT + 4), InputFieldColor, BF
        COLOR InputFieldTextColor
        _PRINTSTRING (InputField.X, DialogY + 5 + _FONTHEIGHT * (3 + totalLines)), MID$(NewValue, InputViewStart, FieldArea)
 
        'Selection highlight:
        GOSUB SelectionHighlight
 
        'Cursor blink:
        IF TIMER - SetCursor# > .4 THEN
            SetCursor# = TIMER
            IF cursorBlink% = 1 THEN cursorBlink% = 0 ELSE cursorBlink% = 1
        END IF
        IF cursorBlink% = 1 THEN
            LINE (InputField.X + (Cursor - (InputViewStart - 1)) * CharW, DialogY + 5 + _FONTHEIGHT * (3 + totalLines))-STEP(0, _FONTHEIGHT), _RGB32(0, 0, 0)
        END IF
 
        'Check if buttons have been clicked or are being hovered:
        GOSUB CheckButtons
 
        'Draw buttons:
        FOR cb = 1 TO TotalButtons
            _PRINTSTRING (Buttons(cb).X, Buttons(cb).Y), RTRIM$(LTRIM$(Buttons(cb).CAPTION))
            IF cb = DefaultButton THEN
                COLOR _RGB32(255, 255, 0)
                _PRINTSTRING (Buttons(cb).X, Buttons(cb).Y), "<" + SPACE$(LEN(RTRIM$(LTRIM$(Buttons(cb).CAPTION))) - 2) + ">"
                COLOR _RGB32(0, 178, 179)
                _PRINTSTRING (Buttons(cb).X - 1, Buttons(cb).Y - 1), "<" + SPACE$(LEN(RTRIM$(LTRIM$(Buttons(cb).CAPTION))) - 2) + ">"
                COLOR _RGB32(0, 0, 0)
            END IF
        NEXT cb
 
        _DISPLAY
 
        'Process input:
        k = _KEYHIT
        IF k = 100303 OR k = 100304 THEN shiftDown = -1
        IF k = -100303 OR k = -100304 THEN shiftDown = 0
        IF k = 100305 OR k = 100306 THEN ctrlDown = -1
        IF k = -100305 OR k = -100306 THEN ctrlDown = 0
 
        SELECT CASE k
            CASE 13: DIALOGRESULT = 1
            CASE 27: DIALOGRESULT = 2
            CASE 32 TO 126 'Printable ASCII characters
                IF k = ASC("v") OR k = ASC("V") THEN 'Paste from clipboard (Ctrl+V)
                    IF ctrlDown THEN
                        Clip$ = _CLIPBOARD$
                        FindLF% = INSTR(Clip$, CHR$(13))
                        IF FindLF% > 0 THEN Clip$ = LEFT$(Clip$, FindLF% - 1)
                        FindLF% = INSTR(Clip$, CHR$(10))
                        IF FindLF% > 0 THEN Clip$ = LEFT$(Clip$, FindLF% - 1)
                        IF LEN(RTRIM$(LTRIM$(Clip$))) > 0 THEN
                            IF NOT Selected THEN
                                IF Cursor = LEN(NewValue) THEN
                                    NewValue = NewValue + Clip$
                                    Cursor = LEN(NewValue)
                                ELSE
                                    NewValue = LEFT$(NewValue, Cursor) + Clip$ + MID$(NewValue, Cursor + 1)
                                    Cursor = Cursor + LEN(Clip$)
                                END IF
                            ELSE
                                s1 = Selection.Start
                                s2 = Cursor
                                IF s1 > s2 THEN SWAP s1, s2
                                NewValue = LEFT$(NewValue, s1) + Clip$ + MID$(NewValue, s2 + 1)
                                Cursor = s1 + LEN(Clip$)
                                Selected = 0
                            END IF
                        END IF
                        k = 0
                    END IF
                ELSEIF k = ASC("c") OR k = ASC("C") THEN 'Copy selection to clipboard (Ctrl+C)
                    IF ctrlDown THEN
                        _CLIPBOARD$ = Selection.Value$
                        k = 0
                    END IF
                ELSEIF k = ASC("x") OR k = ASC("X") THEN 'Cut selection to clipboard (Ctrl+X)
                    IF ctrlDown THEN
                        _CLIPBOARD$ = Selection.Value$
                        GOSUB DeleteSelection
                        k = 0
                    END IF
                ELSEIF k = ASC("a") OR k = ASC("A") THEN 'Select all text (Ctrl+A)
                    IF ctrlDown THEN
                        Cursor = LEN(NewValue)
                        Selection.Start = 0
                        Selected = -1
                        k = 0
                    END IF
                END IF
 
                IF k > 0 THEN
                    IF NOT Selected THEN
                        IF Cursor = LEN(NewValue) THEN
                            NewValue = NewValue + CHR$(k)
                            Cursor = Cursor + 1
                        ELSE
                            NewValue = LEFT$(NewValue, Cursor) + CHR$(k) + MID$(NewValue, Cursor + 1)
                            Cursor = Cursor + 1
                        END IF
                        IF Cursor > FieldArea THEN InputViewStart = (Cursor - FieldArea) + 2
                    ELSE
                        s1 = Selection.Start
                        s2 = Cursor
                        IF s1 > s2 THEN SWAP s1, s2
                        NewValue = LEFT$(NewValue, s1) + CHR$(k) + MID$(NewValue, s2 + 1)
                        Selected = 0
                        Cursor = s1 + 1
                    END IF
                END IF
            CASE 8 'Backspace
                IF LEN(NewValue) > 0 THEN
                    IF NOT Selected THEN
                        IF Cursor = LEN(NewValue) THEN
                            NewValue = LEFT$(NewValue, LEN(NewValue) - 1)
                            Cursor = Cursor - 1
                        ELSEIF Cursor > 1 THEN
                            NewValue = LEFT$(NewValue, Cursor - 1) + MID$(NewValue, Cursor + 1)
                            Cursor = Cursor - 1
                        ELSEIF Cursor = 1 THEN
                            NewValue = RIGHT$(NewValue, LEN(NewValue) - 1)
                            Cursor = Cursor - 1
                        END IF
                    ELSE
                        GOSUB DeleteSelection
                    END IF
                END IF
            CASE 21248 'Delete
                IF NOT Selected THEN
                    IF LEN(NewValue) > 0 THEN
                        IF Cursor = 0 THEN
                            NewValue = RIGHT$(NewValue, LEN(NewValue) - 1)
                        ELSEIF Cursor > 0 AND Cursor <= LEN(NewValue) - 1 THEN
                            NewValue = LEFT$(NewValue, Cursor) + MID$(NewValue, Cursor + 2)
                        END IF
                    END IF
                ELSE
                    GOSUB DeleteSelection
                END IF
            CASE 19200 'Left arrow key
                GOSUB CheckSelection
                IF Cursor > 0 THEN Cursor = Cursor - 1
            CASE 19712 'Right arrow key
                GOSUB CheckSelection
                IF Cursor < LEN(NewValue) THEN Cursor = Cursor + 1
            CASE 18176 'Home
                GOSUB CheckSelection
                Cursor = 0
            CASE 20224 'End
                GOSUB CheckSelection
                Cursor = LEN(NewValue)
        END SELECT
 
        'Cursor adjustments:
        GOSUB CursorAdjustments
    LOOP UNTIL DIALOGRESULT > 0
 
    _KEYCLEAR
    INPUTBOX = DIALOGRESULT
 
    'Restore previous display:
    PCOPY 1, 0
    COLOR FGColor, BGColor
    EXIT SUB
 
    CursorAdjustments:
    IF Cursor > prevCursor THEN
        IF Cursor - InputViewStart + 2 > FieldArea THEN InputViewStart = (Cursor - FieldArea) + 2
    ELSEIF Cursor < prevCursor THEN
        IF Cursor < InputViewStart - 1 THEN InputViewStart = Cursor
    END IF
    prevCursor = Cursor
    IF InputViewStart < 1 THEN InputViewStart = 1
    RETURN
 
    CheckSelection:
    IF shiftDown = -1 THEN
        IF Selected = 0 THEN
            Selected = -1
            Selection.Start = Cursor
        END IF
    ELSEIF shiftDown = 0 THEN
        Selected = 0
    END IF
    RETURN
 
    DeleteSelection:
    NewValue = LEFT$(NewValue, s1) + MID$(NewValue, s2 + 1)
    Selected = 0
    Cursor = s1
    RETURN
 
    SelectionHighlight:
    IF Selected THEN
        s1 = Selection.Start
        s2 = Cursor
        IF s1 > s2 THEN
            SWAP s1, s2
            IF InputViewStart > 1 THEN
                ss1 = s1 - InputViewStart + 1
            ELSE
                ss1 = s1
            END IF
            ss2 = s2 - s1
            IF ss1 + ss2 > FieldArea THEN ss2 = FieldArea - ss1
        ELSE
            ss1 = s1
            ss2 = s2 - s1
            IF ss1 < InputViewStart THEN ss1 = 0: ss2 = s2 - InputViewStart + 1
            IF ss1 > InputViewStart THEN ss1 = ss1 - InputViewStart + 1: ss2 = s2 - s1
        END IF
        Selection.Value$ = MID$(NewValue, s1 + 1, s2 - s1)
 
        LINE (InputField.X + ss1 * CharW, DialogY + 5 + _FONTHEIGHT * (3 + totalLines))-STEP(ss2 * CharW, _FONTHEIGHT), _RGBA32(255, 255, 255, 150), BF
    END IF
    RETURN
 
    CheckButtons:
    'Hover highlight:
    WHILE _MOUSEINPUT: WEND
    mb = _MOUSEBUTTON(1): mx = _MOUSEX: my = _MOUSEY
    FOR cb = 1 TO TotalButtons
        IF (mx >= Buttons(cb).X) AND (mx <= Buttons(cb).X + Buttons(cb).W) THEN
            IF (my >= Buttons(cb).Y) AND (my < Buttons(cb).Y + _FONTHEIGHT) THEN
                LINE (Buttons(cb).X, Buttons(cb).Y)-STEP(Buttons(cb).W, _FONTHEIGHT - 1), _RGBA32(230, 230, 230, 235), BF
            END IF
        END IF
    NEXT cb
 
    IF mb THEN
        IF mx >= InputField.X AND my >= DialogY + 3 + _FONTHEIGHT * (3 + totalLines) AND mx <= InputField.X + (FieldArea * CharW - 10) AND my <= DialogY + 3 + _FONTHEIGHT * (3 + totalLines) + _FONTHEIGHT + 4 THEN
            'Clicking inside the text field positions the cursor
            WHILE _MOUSEBUTTON(1)
                _LIMIT 500
                mb = _MOUSEINPUT
            WEND
            Cursor = ((mx - InputField.X) / CharW) + (InputViewStart - 1)
            IF Cursor > LEN(NewValue) THEN Cursor = LEN(NewValue)
            Selected = 0
            RETURN
        END IF
 
        FOR cb = 1 TO TotalButtons
            IF (mx >= Buttons(cb).X) AND (mx <= Buttons(cb).X + Buttons(cb).W) THEN
                IF (my >= Buttons(cb).Y) AND (my < Buttons(cb).Y + _FONTHEIGHT) THEN
                    DefaultButton = cb
                    WHILE _MOUSEBUTTON(1): _LIMIT 500: mb = _MOUSEINPUT: WEND
                    mb = 0: nmx = _MOUSEX: nmy = _MOUSEY
                    IF nmx = mx AND nmy = my THEN DIALOGRESULT = cb
                    RETURN
                END IF
            END IF
        NEXT cb
    END IF
    RETURN
END FUNCTION
 
 
'method adapted form http://stackoverflow.com/questions/4106363/converting-rgb-to-hsb-colors
FUNCTION hsb~& (__H AS _FLOAT, __S AS _FLOAT, __B AS _FLOAT, A AS _FLOAT)
    DIM H AS _FLOAT, S AS _FLOAT, B AS _FLOAT
 
    H = map(__H, 0, 255, 0, 360)
    S = map(__S, 0, 255, 0, 1)
    B = map(__B, 0, 255, 0, 1)
 
    IF S = 0 THEN
        hsb~& = _RGBA32(B * 255, B * 255, B * 255, A)
        EXIT FUNCTION
    END IF
 
    DIM fmx AS _FLOAT, fmn AS _FLOAT
    DIM fmd AS _FLOAT, iSextant AS INTEGER
    DIM imx AS INTEGER, imd AS INTEGER, imn AS INTEGER
 
    IF B > .5 THEN
        fmx = B - (B * S) + S
        fmn = B + (B * S) - S
    ELSE
        fmx = B + (B * S)
        fmn = B - (B * S)
    END IF
 
    iSextant = INT(H / 60)
 
    IF H >= 300 THEN
        H = H - 360
    END IF
 
    H = H / 60
    H = H - (2 * INT(((iSextant + 1) MOD 6) / 2))
 
    IF iSextant MOD 2 = 0 THEN
        fmd = (H * (fmx - fmn)) + fmn
    ELSE
        fmd = fmn - (H * (fmx - fmn))
    END IF
 
    imx = _ROUND(fmx * 255)
    imd = _ROUND(fmd * 255)
    imn = _ROUND(fmn * 255)
 
    SELECT CASE INT(iSextant)
        CASE 1
            hsb~& = _RGBA32(imd, imx, imn, A)
        CASE 2
            hsb~& = _RGBA32(imn, imx, imd, A)
        CASE 3
            hsb~& = _RGBA32(imn, imd, imx, A)
        CASE 4
            hsb~& = _RGBA32(imd, imn, imx, A)
        CASE 5
            hsb~& = _RGBA32(imx, imn, imd, A)
        CASE ELSE
            hsb~& = _RGBA32(imx, imd, imn, A)
    END SELECT
 
END FUNCTION
 
 
FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
    map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION
 
 
'$INCLUDE:'sxript.bm'
 
 

Graph for Z = X+Y-2

Graph for Z = sin(X)+cos(Y)

Pages: [1] 2 3 4

News:

Show Posts

Topics - Ashish

Programs / JSON Reader

Programs / 3D World Game Engine

Programs / Old Skool Plasma Effect

Programs / Music Visualiser 2D

Programs / Colorful Triangle Geometry

Programs / Pyramid with tile texture

Programs / NEON PEN

Programs / Re: poem generator

Programs / COVID-19 in QB64

Programs / Space Filling with Polygons

Programs / AI : Digit Recognizer

Programs / Re: a test or experiment in epidemiology

Programs / Re: Time/Date Functions

Programs / Re: Not again! Another Time Piece

Programs / 3D Graph Plotter