Attribute VB_Name = "OGLUtils"
Option Explicit

' a couple of declares to work around some deficiencies of the type library
' Problems are with the parameter declaration if someone wants to fix it
' I'd love to have a copy so I can remove these declarations
'  I currently do not have the time to fix vbogl.tlb
'
' Please make sure that you have the type lib registered
' if you do not have a copy of vbogl.tlb
' you can get it here http://is6.pacific.net.hk/~edx/contents.htm

Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As Long
Private Declare Function CreateIC Lib "gdi32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Long) As Long

Private Const CCDEVICENAME = 32
Private Const CCFORMNAME = 32
Private Const HEIGHT_RATIO = 1.5
Private Const MAP_SIZE = 1024
Private Const STEP_SIZE = 8
Dim bRender As Boolean

Dim scaleValue As Single

'Private Const DM_BITSPERPEL = &H40000
'Private Const DM_PELSWIDTH = &H80000
'Private Const DM_PELSHEIGHT = &H100000

' DEVMODE declare used to query Windows for the
' Display device settings
' the one in the typelib has problems so I included this one.
Private Type DEVMODE
    dmDeviceName        As String * CCDEVICENAME
    dmSpecVersion       As Integer
    dmDriverVersion     As Integer
    dmSize              As Integer
    dmDriverExtra       As Integer
    dmFields            As Long
    dmOrientation       As Integer
    dmPaperSize         As Integer
    dmPaperLength       As Integer
    dmPaperWidth        As Integer
    dmScale             As Integer
    dmCopies            As Integer
    dmDefaultSource     As Integer
    dmPrintQuality      As Integer
    dmColor             As Integer
    dmDuplex            As Integer
    dmYResolution       As Integer
    dmTTOption          As Integer
    dmCollate           As Integer
    dmFormName          As String * CCFORMNAME
    dmUnusedPadding     As Integer
    dmBitsPerPel        As Integer
    dmPelsWidth         As Long
    dmPelsHeight        As Long
    dmDisplayFlags      As Long
    dmDisplayFrequency  As Long
End Type

Public Keys(255) As Boolean             ' used to keep track of key_downs

Private hrc As Long                     ' handle for OpenGL redering context
Private fullscreen As Boolean           ' are we in full screen

Private OldWidth As Long                ' used to restore the starting display settings
Private OldHeight As Long               ' Height
Private OldBits As Long                 ' bit per pixel
Private OldVertRefresh As Long          ' and vertical refresh

Private mPointerCount As Integer        ' maintains the number of show/hide cursor calls

Private xSpeed, ySpeed As Single
Private xAngle, yAngle As Single


Private Sub HidePointer()
    ' hide the cursor (mouse pointer)
    mPointerCount = ShowCursor(False) + 1   ' how many times will we need to hide the pointer
    Do While ShowCursor(False) >= -1        ' make sure it's hidden
    Loop
    Do While ShowCursor(True) <= -1         ' make sure the next call will show it
    Loop
    ShowCursor False                        ' one last time
End Sub

Private Sub ShowPointer()
    ' show the cursor (mouse pointer)
    Do While ShowCursor(False) >= mPointerCount ' restore the cursor back to normal
    Loop
    Do While ShowCursor(True) <= mPointerCount
    Loop
End Sub

Public Sub ReSizeGLScene(ByVal Width As GLsizei, ByVal Height As GLsizei)
' Resize And Initialize The GL Window
    If Height = 0 Then              ' Prevent A Divide By Zero By
        Height = 1                  ' Making Height Equal One
    End If
    glViewport 0, 0, Width, Height  ' Reset The Current Viewport
    glMatrixMode mmProjection       ' Select The Projection Matrix
    glLoadIdentity                  ' Reset The Projection Matrix

    ' Calculate The Aspect Ratio Of The Window
    gluPerspective 45#, Width / Height, 0.1, 10000#  '100#

    glMatrixMode mmModelView        ' Select The Modelview Matrix
    glLoadIdentity                  ' Reset The Modelview Matrix
End Sub

Public Function InitGL() As Boolean
' All Setup For OpenGL Goes Here
    glShadeModel smSmooth               ' Enables Smooth Shading

    glClearColor 0#, 0#, 0#, 0.5        ' Black Background

    glClearDepth 1#                     ' Depth Buffer Setup
    glEnable glcDepthTest               ' Enables Depth Testing
    glDepthFunc cfLEqual                ' The Type Of Depth Test To Do

    glHint htPerspectiveCorrectionHint, hmNicest    ' Really Nice Perspective Calculations

    InitGL = True                       ' Initialization Went OK
'    xSpeed = 0.1   ' start with some movement
'    ySpeed = 0.1
    xSpeed = 1   ' start with some movement
    ySpeed = 1
    
End Function


Public Sub KillGLWindow()
' Properly Kill The Window
    If fullscreen Then                              ' Are We In Fullscreen Mode?
        ResetDisplayMode                            ' If So Switch Back To The Desktop
        ShowPointer                                 ' Show Mouse Pointer
    End If

    If hrc Then                                     ' Do We Have A Rendering Context?
        If wglMakeCurrent(0, 0) = 0 Then             ' Are We Able To Release The DC And RC Contexts?
            MsgBox "Release Of DC And RC Failed.", vbInformation, "SHUTDOWN ERROR"
        End If

        If wglDeleteContext(hrc) = 0 Then           ' Are We Able To Delete The RC?
            MsgBox "Release Rendering Context Failed.", vbInformation, "SHUTDOWN ERROR"
        End If
        hrc = 0                                     ' Set RC To NULL
    End If

    ' Note
    ' The form owns the device context (hDC) window handle (hWnd) and class (RTThundermain)
    ' so we do not have to do all the extra work

End Sub

Private Sub SaveCurrentScreen()
    ' Save the current screen resolution, bits, and Vertical refresh
    Dim ret As Long
    ret = CreateIC("DISPLAY", "", "", 0&)           ' create display information context
    OldWidth = GetDeviceCaps(ret, HORZRES)          ' get the current width
    OldHeight = GetDeviceCaps(ret, VERTRES)         ' and current height
    OldBits = GetDeviceCaps(ret, BITSPIXEL)         ' and bits per pixel (color depth)
    OldVertRefresh = GetDeviceCaps(ret, VREFRESH)   ' and current refresh rate (this may cause problems in Win98
    ret = DeleteDC(ret)                             ' delete the information context
End Sub

Private Function FindDEVMODE(ByVal Width As Integer, ByVal Height As Integer, ByVal Bits As Integer, Optional ByVal VertRefresh As Long = -1) As DEVMODE
    ' locate a DEVMOVE that matches the passed parameters
    Dim ret As Boolean      ' return value from api
    Dim i As Long           ' loop counter
    Dim dm As DEVMODE       ' Device mode
    i = 0
    Do  ' enumerate the display settings until we find the one we want
        ret = EnumDisplaySettings(0&, i, dm)    ' get windows to enumerate the display settings
        If dm.dmPelsWidth = Width And _
            dm.dmPelsHeight = Height And _
            dm.dmBitsPerPel = Bits And _
            ((dm.dmDisplayFrequency = VertRefresh) Or (VertRefresh = -1)) Then Exit Do ' exit when we have a match
        i = i + 1
    Loop Until (ret = False)
    FindDEVMODE = dm
End Function

Private Sub ResetDisplayMode()
    Dim dm As DEVMODE             ' Device Mode
    
    dm = FindDEVMODE(OldWidth, OldHeight, OldBits, OldVertRefresh) ' find our old display mode
    dm.dmFields = DM_BITSPERPEL Or DM_PELSWIDTH Or DM_PELSHEIGHT    ' what we are about to change
    If OldVertRefresh <> -1 Then
        dm.dmFields = dm.dmFields Or DM_DISPLAYFREQUENCY            ' include vertical refresh
    End If
    ' Try To Set Selected Mode And Get Results.  NOTE: CDS_FULLSCREEN Gets Rid Of Start Bar.
    If (ChangeDisplaySettings(dm, CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL) Then
    
        ' If The Mode Fails, Offer Two Options.  Quit Or Run In A Window.
        MsgBox "The Requested Mode Is Not Supported By Your Video Card", , "Fatal"
    End If

End Sub

Private Sub SetDisplayMode(ByVal Width As Integer, ByVal Height As Integer, ByVal Bits As Integer, ByRef fullscreen As Boolean, Optional VertRefresh As Long = -1)
    Dim dmScreenSettings As DEVMODE             ' Device Mode
    Dim p As Long
    SaveCurrentScreen                           ' save the current screen attributes so we can go back later
    
    dmScreenSettings = FindDEVMODE(Width, Height, Bits, VertRefresh) ' find a device mode that matches
    dmScreenSettings.dmBitsPerPel = Bits    ' set pixel bits
    dmScreenSettings.dmPelsWidth = Width    ' width
    dmScreenSettings.dmPelsHeight = Height  ' height
    dmScreenSettings.dmFields = DM_BITSPERPEL Or DM_PELSWIDTH Or DM_PELSHEIGHT ' what we are going to change
    If VertRefresh <> -1 Then
        dmScreenSettings.dmDisplayFrequency = VertRefresh ' include vertical refresh
        dmScreenSettings.dmFields = dmScreenSettings.dmFields Or DM_DISPLAYFREQUENCY
    End If
    ' Try To Set Selected Mode And Get Results.  NOTE: CDS_FULLSCREEN Gets Rid Of Start Bar.
    If (ChangeDisplaySettings(dmScreenSettings, CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL) Then
    
        ' If The Mode Fails, Offer Two Options.  Quit Or Run In A Window.
        If (MsgBox("The Requested Mode Is Not Supported By" & vbCr & "Your Video Card. Use Windowed Mode Instead?", vbYesNo + vbExclamation, "Fatal") = vbYes) Then
            fullscreen = False                  ' Select Windowed Mode (Fullscreen=FALSE)
        Else
            ' Pop Up A Message Box Letting User Know The Program Is Closing.
            MsgBox "Program Will Now Close.", vbCritical, "ERROR"
            End                   ' Exit And Return FALSE
        End If
    End If
End Sub

Public Function DrawGLScene() As Boolean
' Here's Where We Do All The Drawing
  
  glClear clrColorBufferBit Or clrDepthBufferBit  ' Clear The Screen And The Depth Buffer
  glLoadIdentity                                  ' Reset The Current Modelview Matrix
         
  If Keys(vbKeyLeft) Then Let yAngle = yAngle - ySpeed
  If Keys(vbKeyRight) Then Let yAngle = yAngle + ySpeed
  
  'If Keys(vbKeyAdd) Then xAngle = xAngle + xSpeed
  'If Keys(vbKeySubtract) Then xAngle = xAngle - xSpeed
  If Keys(vbKeyAdd) Then scaleValue = scaleValue + 0.001
  If Keys(vbKeySubtract) Then scaleValue = scaleValue - 0.001
  'If Keys(vbKeyUp) Then scaleValue = scaleValue + 0.001
  'If Keys(vbKeyDown) Then scaleValue = scaleValue - 0.001
  If Keys(vbKeyUp) Then xAngle = xAngle + xSpeed
  If Keys(vbKeyDown) Then xAngle = xAngle - xSpeed
   
  If Keys(vbKeySpace) Then bRender = Not bRender
  Call glRotatef(xAngle, 1, 0, 0)
  Call glRotatef(yAngle, 0, 1, 0)
  
'  Call glRotatef(yAngle, 0, 0, 1)
'  Call glRotatef(xAngle, 0, 0, 1)
  'Call glTranslatef(0#, 0#, -5000)
  Call gluLookAt(212, 60, 194, 186, 55, 171, 0, 1, 0)     'This Determines Where The Camera's Position And View Is
  Call glScalef(scaleValue, scaleValue * HEIGHT_RATIO, scaleValue)

  Call RenderHeightMap                        ' Render The Height Map
  
  'Call triangles
  
  DrawGLScene = True                              ' Everything Went OK
End Function

Public Function CreateGLWindow(frm As Form, Width As Integer, Height As Integer, Bits As Integer, fullscreenflag As Boolean) As Boolean
    Dim PixelFormat As GLuint                       ' Holds The Results After Searching For A Match
    Dim pfd As PIXELFORMATDESCRIPTOR                ' pfd Tells Windows How We Want Things To Be


    fullscreen = fullscreenflag                     ' Set The Global Fullscreen Flag


    If (fullscreen) Then                            ' Attempt Fullscreen Mode?
        SetDisplayMode Width, Height, Bits, fullscreen
    End If
    
    If fullscreen Then
        HidePointer                                 ' Hide Mouse Pointer
        frm.WindowState = vbMaximized           ' make the form big
    End If

    pfd.cColorBits = Bits               ' color depth
    pfd.cDepthBits = 16
    pfd.dwflags = PFD_DRAW_TO_WINDOW Or PFD_SUPPORT_OPENGL Or PFD_DOUBLEBUFFER
    pfd.iLayerType = PFD_MAIN_PLANE
    pfd.iPixelType = PFD_TYPE_RGBA
    pfd.nSize = Len(pfd)
    pfd.nVersion = 1
    
    PixelFormat = ChoosePixelFormat(frm.hDC, pfd)
    If PixelFormat = 0 Then                     ' Did Windows Find A Matching Pixel Format?
        KillGLWindow                            ' Reset The Display
        MsgBox "Can't Find A Suitable PixelFormat.", vbExclamation, "ERROR"
        CreateGLWindow = False                  ' Return FALSE
    End If

    If SetPixelFormat(frm.hDC, PixelFormat, pfd) = 0 Then ' Are We Able To Set The Pixel Format?
        KillGLWindow                            ' Reset The Display
        MsgBox "Can't Set The PixelFormat.", vbExclamation, "ERROR"
        CreateGLWindow = False                           ' Return FALSE
    End If
    
    hrc = wglCreateContext(frm.hDC)
    If (hrc = 0) Then                           ' Are We Able To Get A Rendering Context?
        KillGLWindow                            ' Reset The Display
        MsgBox "Can't Create A GL Rendering Context.", vbExclamation, "ERROR"
        CreateGLWindow = False                  ' Return FALSE
    End If

    If wglMakeCurrent(frm.hDC, hrc) = 0 Then    ' Try To Activate The Rendering Context
        KillGLWindow                            ' Reset The Display
        MsgBox "Can't Activate The GL Rendering Context.", vbExclamation, "ERROR"
        CreateGLWindow = False                  ' Return FALSE
    End If
    frm.Show                                    ' Show The Window
    SetForegroundWindow frm.hWnd                ' Slightly Higher Priority
    frm.SetFocus                                ' Sets Keyboard Focus To The Window
    ReSizeGLScene frm.ScaleWidth, frm.ScaleHeight ' Set Up Our Perspective GL Screen

    If Not InitGL() Then                        ' Initialize Our Newly Created GL Window
        KillGLWindow                            ' Reset The Display
        MsgBox "Initialization Failed.", vbExclamation, "ERROR"
        CreateGLWindow = False                   ' Return FALSE
    End If

    CreateGLWindow = True                       ' Success

End Function

Sub GLmain()
    'Set up the values to do with key bindings
    Let scaleValue = 0.15 ' Scale Value For The Terrain (NEW)
    Let bRender = True 'wirefram or textured object
   
    
    Dim Done As Boolean
    Dim frm As Form
    Done = False ' we're not done yet
    ' Ask The User Which Screen Mode They Prefer
    fullscreen = MsgBox("Would You Like To Run In Fullscreen Mode?", vbYesNo + vbQuestion, "Start FullScreen?") = vbYes
    
    ' Create Our OpenGL Window
    Set frm = New frmVisualise     ' create our form
    If Not CreateGLWindow(frm, 800, 600, 16, fullscreen) Then
        Done = True                             ' Quit If Window Was Not Created
    End If

    Do While Not Done
        ' Draw The Scene.  Watch For ESC Key And Quit Messages From DrawGLScene()
        If (Not DrawGLScene Or Keys(vbKeyEscape)) Then  ' Updating View Only If Active
            frm.Visible = False
            Call KillGLWindow
            Unload frm                 ' ESC or DrawGLScene Signalled A Quit
            frmImport.Show
            
        Else                                    ' Not Time To Quit, Update Screen
            SwapBuffers (frm.hDC)               ' Swap Buffers (Double Buffering)
            DoEvents
        End If

        If Keys(vbKeyF1) Then                   ' Is F1 Being Pressed?
            Keys(vbKeyF1) = False               ' If So Make Key FALSE
            Unload frm                          ' Kill Our Current Window
            Set frm = New frmVisualise                 ' create a new one
            fullscreen = Not fullscreen         ' Toggle Fullscreen / Windowed Mode
            ' Recreate Our OpenGL Window
            If Not CreateGLWindow(frm, 640, 480, 16, fullscreen) Then
                Unload frm                      ' Quit If Window Was Not Created
            End If
        End If
        Done = frm.Visible = False              ' if the form is not visible then we are done
    Loop
    ' Shutdown
    Set frm = Nothing ' destroy our form
    
End Sub

Private Sub triangles()
  Dim i As Integer
  Dim X As Double
  Dim Y As Double
  Dim z As Double
  Dim q As Integer
  Dim points(1 To 2250, 1 To 3) As Double
     
   'Global array dosnt work so create a local one and insert values from local array
   For i = 1 To RecordCounter
        Let points(i, 1) = Northing(i)
        Let points(i, 2) = Easting(i)
        Let points(i, 3) = masl(i)
   Next i
     
  glBegin bmTriangles
    Let X = 469400
    Let Y = 7324955
    Let z = 776

    For i = 1 To RecordCounter
       glColor3f 1#, 0#, 0#
       Call glVertex3f(X - points(i, 1), Y - points(i, 2), z - points(i, 3))
       Call glVertex3f(X - points(i, 1) + 50, Y - points(i, 2), z - points(i, 3))
       Call glVertex3f(X - points(i, 1), Y - points(i, 2) + 50, z - points(i, 3))
    
       'Using the global array dosnt work, no idea why
    '   Call glVertex3f(x - Northing(i), y - Easting(i), z - Masl(i))
    '   Call glVertex3f(x - Northing(i) + 50, y - Easting(i), z - Masl(i))
    '   Call glVertex3f(x - Northing(i), y - Easting(i) + 50, z - Masl(i))
    Next i
  glEnd
 
End Sub

Private Sub RenderHeightMap()
    Dim XX As Integer          'Create Some Variables For Readability
    Dim YY As Integer
    Dim X As Integer
    Dim Y As Integer
    Dim z As Integer
    
    Let XX = 0
    Let YY = 0
    glShadeModel (smSmooth)
    
    If bRender Then                                   ' What We Want To Render
        glBegin bmQuads                            ' Render Polygons
    Else
        glBegin bmLines                            ' Render Lines Instead
    End If
    For XX = 0 To MAP_SIZE Step STEP_SIZE
        For YY = 0 To MAP_SIZE Step STEP_SIZE
           ' Get The (XX, YY, Z) Value For The Bottom Left Vertex
            X = XX
            Y = Height(XX, YY)
            z = YY

            ' Set The Color Value Of The Current Vertex
            Call SetVertexColour(X, z)

            Call glVertex3i(X, Y, z)         'Send This Vertex To OpenGL To Be Rendered (Integer Points Are Faster)

            ' Get The (XX, YY, Z) Value For The Top Left Vertex
            X = XX
            Y = Height(XX, YY + STEP_SIZE)
            z = YY + STEP_SIZE
            
            ' Set The Color Value Of The Current Vertex
            Call SetVertexColour(X, z)

            Call glVertex3i(X, Y, z)      ' Send This Vertex To OpenGL To Be Rendered

            ' Get The (XX, YY, Z) Value For The Top Right Vertex
            X = XX + STEP_SIZE
            Y = Height(XX + STEP_SIZE, YY + STEP_SIZE)
            z = YY + STEP_SIZE

            ' Set The Color Value Of The Current Vertex
            Call SetVertexColour(X, z)
            
            Call glVertex3i(X, Y, z)        ' Send This Vertex To OpenGL To Be Rendered

            ' Get The (XX, YY, Z) Value For The Bottom Right Vertex
            X = XX + STEP_SIZE
            Y = Height(XX + STEP_SIZE, YY)
            z = YY

            ' Set The Color Value Of The Current Vertex
            Call SetVertexColour(X, z)

            Call glVertex3i(X, Y, z)        'Send This Vertex To OpenGL To Be Rendered
 
     Next YY
  Next XX
    glEnd

    Call glColor4f(1#, 1#, 1#, 1#)                 ' Reset The Color
End Sub

Private Function Height(XX As Integer, YY As Integer) As Integer          ' This Returns The Height From A Height Map Index
    Dim X As Integer
    Dim Y As Integer
    
    X = XX Mod MAP_SIZE                              ' Error Check Our x Value
    Y = YY Mod MAP_SIZE                              ' Error Check Our y Value

    Height = Terrain(X, Y)              ' Index Into Our Height Array And Return The Height
End Function

Private Sub SetVertexColour(X As Integer, Y As Integer)
   ' Sets The Color Value For A Particular Index, Depending On The Height Index
   Dim rcolour As Single
   Dim gcolour As Single
   Dim bcolour As Single
   Dim Correction As Single
   Let Correction = 0.15
   
   Let rcolour = (Correction + Height(X, Y) / 256#)
   Let gcolour = (Correction + Height(X, Y) / 256#)
   Let bcolour = (Correction + Height(X, Y) / 256#)
   ' Assign This Blue Shade To The Current Vertex
   Call glColor3f(rcolour, gcolour, bcolour)

End Sub