globe.bas

Powerbasic 对GDI 的操作 很漂亮的代码!

                                 zInstance, _                 ' program instance handle
                                 BYVAL 0)                     ' creation parameters
          CALL ZI_SetAnchorMode(glWnd, %ANCHOR_HEIGHT_WIDTH)  ' Anchor the control (make it a resizable)
        ' OpenGL section                                      ' ----------------------------------------
        ' Load any of the supported GDImage graphic format to create a texture
          CALL ZI_DoNotSquareTexture() ' Do not fit the texture into a square shape

          DIM mt(1 TO 2) AS ZGLTEXTURE
          mt(1).FullName = "earthmap.jpg": mt(1).ID = 1
          mt(2).FullName = "stars-in-night.jpg": mt(2).ID = 2
          IF ZI_SetMutipleGLTextureFromFile (BYVAL VARPTR(mt(LBOUND(mt))), UBOUND(mt) - LBOUND(mt) + 1) = 0 THEN
             CALL ZI_InitGLControl(ZD_ColorARGB(255, RGB(0,0,16)))
             CALL InitializeGL()
             
             UseFont.fontName = "Arial"
             UseFont.fontHeight = 10
             UseFont.fontWeight = %FW_BOLD
             CALL ZI_BuildGLfont(ZI_GetGLDC(glWnd), UseFont) ' Build OpenGL font for our OpenGL window
             CALL GlobalFont(UseFont, 1)
          END IF

        ' Show the main window
          CALL ShowWindow(hMain, iCmdShow)
          CALL SetForegroundWindow(hMain)                ' Slightly Higher Priority
          CALL SetFocus(hMain)                           ' Sets Keyboard Focus To The Window

        ' *******************************************************
        ' This is a special message loop to render fast animation
        ' *******************************************************
          WHILE Done = %FALSE                             ' Loop That Runs While done = %FALSE
             IF PeekMessage(Msg, %NULL, 0, 0, %PM_REMOVE) THEN ' Is There A Message Waiting?
                IF msg.message = %WM_QUIT THEN            ' Have We Received A Quit Message?
                   Done = %TRUE                           ' If So done = %TRUE
                ELSE                                      ' If Not, Deal With Window Messages
                   'IF TranslateAccelerator(ghWnd, hAccel, Msg) = 0 THEN
                      CALL TranslateMessage(msg)          ' Translate The Message
                      CALL DispatchMessage(msg)           ' Dispatch The Message
                   'END IF
                END IF
             ELSE                                         ' If there are no pending messages
                IF Active THEN                            ' Draw The Scene.
                   
                   IF GetFocus <> hMain THEN              ' Do they hold down a Zoom button
                      CALL MessageButton(hMain, Msg) 
                   END IF

                   CALL DrawTheScene(UseFont)             ' Draw the Scene (Don't draw when inactive 1% CPU Use)
                   IF IsZoomed(hMain) = 0 THEN CALL apisleep(1)


                ELSE                                      ' When minimized don't hog the CPU.
                   CALL apiSleep(100)
                END IF
             END IF
          WEND

          FUNCTION = msg.wParam
       END IF

     ' UNLOAD the WinXP Theme DLL (if necessary)
       IF hWinXP_Lib THEN CALL FreeLibrary(hWinXP_Lib)

    END IF
'
    CALL ZI_DeleteGLFont(UseFont)
    IF hMutex THEN CALL CloseHandle(hMutex)
'
END FUNCTION

%GL_SMOOTH                          = &H1D01
%GL_PERSPECTIVE_CORRECTION_HINT     = &H0C50
%GL_NICEST                          = &H1102
DECLARE SUB glShadeModel LIB "opengl32.dll" ALIAS "glShadeModel" (BYVAL mode AS DWORD)
DECLARE SUB glHint LIB "opengl32.dll" ALIAS "glHint" (BYVAL ntarget AS DWORD, BYVAL mode AS DWORD)

SUB ResetGlobe()
    Vert  = 75
    Horz  = 0
    latinc = 0
    longinc = 0
END SUB

' Set up our OpenGL scene
SUB InitializeGL()

    CALL ResetGlobe()
    'CALL glShadeModel(%GL_SMOOTH)                                 ' Enable Smooth Shading
    'CALL glHint(%GL_PERSPECTIVE_CORRECTION_HINT, %GL_NICEST)      ' Do nicest perspective

    DIM LightAmbient(3) AS SINGLE:  ARRAY ASSIGN LightAmbient()  = 0.05, 0.05, 0.05, 1.0
    DIM LightDiffuse(3) AS SINGLE:  ARRAY ASSIGN LightDiffuse()  = 1.0, 1.0, 1.0, 1.0
    DIM LightPosition(3) AS SINGLE: ARRAY ASSIGN LightPosition() = 20.0, 0.0, 30.0, 1.0
    CALL glLightfv(%GL_LIGHT0, %GL_AMBIENT, LightAmbient(0))      ' Setup The Ambient Light
    CALL glLightfv(%GL_LIGHT0, %GL_DIFFUSE, LightDiffuse(0))      ' Setup The Diffuse Light
    CALL glLightfv(%GL_LIGHT0, %GL_POSITION, LightPosition(0))    ' Position The Light

'   Disable this there, because we don't want to change the light of the image background
'   CALL glEnable(%GL_LIGHT0)                                     ' Enable Light ZERO
'   CALL glEnable(%GL_LIGHTING)                                   ' Enable Lighting
'   CALL glEnable(%GL_COLOR_MATERIAL)                             ' Enable Coloring Of Material

END SUB

SUB DrawTheScene(UseFont AS ZGLFONT)
    LOCAL Radius AS SINGLE, quadObj AS LONG

    STATIC UseColor AS LONG

    CALL glClear(%GL_COLOR_BUFFER_BIT OR %GL_DEPTH_BUFFER_BIT)

  ' Draw background image -----------------------------------------
    CALL glDisable(%GL_LIGHT0)                                     ' Enable Light ZERO
    CALL glDisable(%GL_LIGHTING)                                   ' Enable Lighting
    CALL glDisable(%GL_COLOR_MATERIAL)                             ' Enable Coloring Of Material
    CALL glBindTexture(%GL_TEXTURE_2D, 2)
    CALL glBegin(%GL_QUADS)
       CALL glTexCoord2f(0.0, 0.0): CALL glVertex3f(-60,-40,-70.0) ' Bottom Left Of The Texture And Quad
       CALL glTexCoord2f(1.0, 0.0): CALL glVertex3f( 60,-40,-70.0) ' Bottom Right Of The Texture And Quad
       CALL glTexCoord2f(1.0, 1.0): CALL glVertex3f( 60, 40,-70.0) ' Top Right Of The Texture And Quad
       CALL glTexCoord2f(0.0, 1.0): CALL glVertex3f(-60, 40,-70.0) ' Top Left Of The Texture And Quad
    CALL glEnd()
  ' ----------------------------------------------------------------
    CALL glEnable(%GL_LIGHT0)                                      ' Enable Light ZERO
    CALL glEnable(%GL_LIGHTING)                                    ' Enable Lighting
    CALL glEnable(%GL_COLOR_MATERIAL)                              ' Enable Coloring Of Material

    IF UseColor& = 0 THEN UseColor& = ZD_ColorARGB(255, RGB(128,0,0))

    Lgt& = ABS(CINT(Horz)): IF Lgt& > 180 THEN Lgt& = 360 - Lgt&
    CALL ZI_DrawGLText(glWnd, UseFont, 10, 10, ("Longitude " + STR$(Lgt&)), UseColor)

    aLat& = CINT(ABS(Vert)): Lat& = 90 - (aLat& MOD 90): IF aLat& MOD 180 > 90 THEN Lat& = (aLat& mod 180) - 90
    CALL ZI_DrawGLText(glWnd, UseFont, 22, 10 + UseFont.fontHeight, ("Latitude " + STR$(Lat&)), UseColor)

    CALL ZI_DrawGLText(glWnd, UseFont, 39, 10 + UseFont.fontHeight * 2, ("Zoom " + STR$(ZI_GetGLzoom(glWnd))), UseColor)

    CALL glBindTexture(%GL_TEXTURE_2D, 1)
    CALL glPushMatrix()
         Vert = (Vert + latinc) MOD 360
         Horz = (Horz + longinc) MOD 360
         Radius = 4.5
         CALL ZI_UseGLPolarView(Radius, 0, Vert, Horz)
       ' Draw GLOBE
         quadObj = gluNewQuadric()                        ' Pointer to the Quadric Object (Return 0 If No Memory))
         IF quadObj THEN
            CALL gluQuadricNormals(quadObj, %GLU_SMOOTH)  ' Create Smooth Normals
            CALL gluQuadricTexture(quadObj, %GL_TRUE)     ' Create Texture Coords
            CALL gluSphere(quadObj, 1.5, 48, 48) ' 32, 32)
            CALL gluDeleteQuadric(quadObj)
         END IF
    CALL glPopMatrix()

    CALL ZI_UpdateGLWindow(glWnd)
END SUB

FUNCTION WndProc(BYVAL hWin AS LONG, BYVAL Msg AS LONG, BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG
    
    LOCAL ps AS PAINTSTRUCT, lp AS POINTAPI, ZoomIs AS LONG, UseFont AS ZGLFONT

    STATIC wasX&, wasY&

    SELECT CASE Msg&

    CASE %WM_ACTIVATE                                ' Watch For Window Activate Message
         IF HIWRD(wParam) = 0 THEN                   ' Check Minimization State
            Active = 1                               ' Program Is Active
         ELSE                                        ' Otherwise
            Active = 0                               ' Program Is No Longer Active
         END IF

    CASE %WM_SIZE
         CALL ZI_ResizeGLWindow(glWnd)
         CALL GlobalFont(UseFont, 0): CALL DrawTheScene(UseFont)

    CASE %WM_COMMAND
         wP& = LOWRD(wParam&)

         SELECT CASE LONG wP&
         CASE %ID_START
              longinc = 0.05

         CASE %ID_LEFT
              longinc = longinc + 0.05

         CASE %ID_RIGHT
              longinc = longinc - 0.05

         CASE %ID_UP
              latinc  = latinc + 0.05

         CASE %ID_DOWN
              latinc  = latinc - 0.05

         CASE %ID_RESET
              CALL ResetGlobe()
              CALL ZI_SetGLzoom(glWnd, 0): CALL ZI_ResizeGLWindow(glWnd)
              CALL GlobalFont(UseFont, 0): CALL DrawTheScene(UseFont)

         CASE %ID_NEW_IMAGE
              FilName$ = ZI_LoadDialog(hWin&)
              IF LEN(FilName$) THEN
                 CALL ZI_DoNotSquareTexture()
                 NamedTexture& = 1 ' The Globe
                 CALL ZI_UpdateNamedGLTextureFromFile((FilName$), NamedTexture&)
              END IF

         END SELECT
         IF GetFocus <> hWin THEN CALL SetFocus(hWin)

    CASE %WM_KEYDOWN
         SELECT CASE LONG wParam
         CASE %VK_LEFT
              longinc = longinc + 0.05
         CASE %VK_RIGHT
              longinc = longinc - 0.05
         CASE %VK_UP
              latinc  = latinc  + 0.05
         CASE %VK_DOWN
              latinc  = latinc  - 0.05
         CASE %VK_PGUP
              ZoomIs = ZI_GetGLzoom(glWnd)
              IF ZoomIs > 1 THEN
                 CALL ZI_SetGLzoom(glWnd, ZoomIs - 1): CALL ZI_ResizeGLWindow(glWnd)
              END IF
         CASE %VK_PGDN
              ZoomIs = ZI_GetGLzoom(glWnd)
              IF ZoomIs < 180 THEN
                 CALL ZI_SetGLzoom(glWnd, ZoomIs + 1): CALL ZI_ResizeGLWindow(glWnd)
              END IF
         END SELECT
         FUNCTION = 0: EXIT FUNCTION

    CASE %WM_PAINT
         CALL GradientPaint(hWin&, RGB(228,227,227), RGB(168,167,191))
         FUNCTION = 0: EXIT FUNCTION
    CASE %WM_DESTROY
         CALL PostQuitMessage(0)
         FUNCTION = 0: EXIT FUNCTION
    END SELECT
    FUNCTION = DefWindowProc(hWin&, Msg&, wParam&, lParam&)
END FUNCTION

SUB GradientPaint(BYVAL hWin&, BYVAL TopRGB&, BYVAL BottomRGB&)
    LOCAL ps AS PAINTSTRUCT
    LOCAL rc AS RECT
  ' Tile the background
    CALL GetClientRect (hWin&, rc)
    hDC& = BeginPaint(hWin&, ps)
    CALL ZI_GradientPaintDC(hDC&, 0, 0, rc.nRight, rc.nBottom, TopRGB&, BottomRGB&)
    CALL EndPaint(hWin&, ps)
END SUB