Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

3D-Graphics Demonstration Program

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • 3D-Graphics Demonstration Program

    the original version is now replaced by the updated version below.

    comments to the program are here:
    http://www.powerbasic.com/support/pb...ead.php?t=5482

    regards,

    erik

    april 5: thanks to some very fine comments on graphics in the
    programming forum i got inspired to make further improvements
    to the program. thank you very much.

    april 7: thanks to brad byrne's suggestions the mouse can now
    be used to move the object when the left mouse button is held down.


    [this message has been edited by erik christensen (edited april 07, 2002).]

  • #2
    ' 3D-Graphics Demonstration Program.
    '
    ' Re-re-updated version: April 7, 2002
    '
    ' This program illustrates the drawing of three-dimensional objects on
    ' the screen. It includes routines for not displaying surfaces and
    ' edges which cannot be seen from the eye or viewpoint position.
    ' A key point in the program is the concept of surface orientation.
    ' The vertices (corners) of each surface unit (facet) must follow a
    ' counter-clockwise sequence when seen from the outer side of the
    ' surface. The object must be composed of convex facets. If you want
    ' to show objects with concave facets such must first be broken down
    ' to two or more convex facets. The coordinate system used is left-
    ' hand orientated. For further background information you should
    ' consult textbooks on computer graphics.
    '
    ' The program allows you to change the eye (viewpoint) position
    ' coordinates and the degree of perspective. You are always looking
    ' toward the center (0,0,0) of the coordinate system. So it is best
    ' if you place the object in such a way that its center is at 0,0,0.
    ' PowerBasic's handy matrix functions are being used for
    ' transformation of coordinates. You can make the object rotate
    ' continuously left or right. The flicker has been reduced by making the
    ' drawing in a virtual window. Repainting is done by copying the virtual
    ' window to the screen window. This updating has been inspired by the
    ' very fine contributions by the many experts in the Forum, whom I thank
    ' very much. This late version allows you to move the object using the mouse
    ' as long as the left mouse button is held down. Thanks to Brad Byrne for
    ' suggesting this feature and to Todd Wasson for his code on 3-D vector
    ' graphics which demonstrates how the viewpoint can be controlled by the
    ' mouse. Also thanks to Karl Lessmann for his comments. Further suggestions for
    ' improvement are still welcome.
    '
    ' Best wishes
    '
    ' Erik Christensen ----- e.chr@email.dk
    '
    ' August 21: Updated function CalculatePhi
    Code:
    #COMPILE EXE
    #REGISTER NONE
    #DIM ALL
    '
    #INCLUDE "win32api.inc"
    ' ----------------------------------------------------------
    %Form1_FILE                                     = 500
    ' ----------------------------------------------------------
    %Form1_DEFAULT                                  = 505
    %Form1_OPENFILE                                 = 510
    %Form1_SAVEAS                                   = 515
    %Form1_SEPARATOR_520                            = 520
    %Form1_SAVE_CUR_GRAPH                           = 522
    %Form1_SEPARATOR_524                            = 524
    %Form1_EXIT                                     = 525
    ' ----------------------------------------------------------
    %Form1_EDIT                                     = 600
    ' ----------------------------------------------------------
    %Form1_HELP                                     = 700
    ' ----------------------------------------------------------
    %Form1_HELP1                                    = 705
    %Form1_ABOUT                                    = 710
    %FORM1_LABEL_VIEWPOINT       = 100
    %FORM1_LABEL_MOUSEINF        = 102
    %FORM1_GRAPHLABEL            = 105
    %FORM1_BUTTON_UP             = 110
    %FORM1_BUTTON_DOWN           = 115
    %FORM1_BUTTON_LEFT           = 120
    %FORM1_BUTTON_RIGHT          = 125
    %FORM1_BUTTON_CLOSER         = 130
    %FORM1_BUTTON_FARTHER        = 135
    %FORM1_BUTTON_MORE_PERSPEC   = 140
    %FORM1_BUTTON_LESS_PERSPEC   = 145
    %FORM1_BUTTON_ROT_LEFT       = 150
    %FORM1_BUTTON_ROT_RIGHT      = 155
    %FORM1_BUTTON_ROT_STOP       = 160
    
    ' --------------------------------------------------
    DECLARE SUB ShowDialog_Form1(BYVAL hParent&)
    DECLARE CALLBACK FUNCTION Form1_DLGPROC
    DECLARE SUB Form1_HELP1_Select()
    DECLARE SUB Form1_ABOUT_Select()
    DECLARE FUNCTION MakeFont(BYVAL FontTypeSize AS LONG,BYVAL FontWeight AS LONG, _
        BYVAL Italic AS LONG, BYVAL Underline AS LONG,BYVAL StrikeOut AS LONG, _
        BYVAL FaceName AS STRING) AS LONG
    DECLARE FUNCTION CalculatePhi(EX AS SINGLE, EZ AS SINGLE) AS SINGLE
    DECLARE FUNCTION gColor(BYVAL I AS LONG) AS LONG
    DECLARE FUNCTION PenStyle(BYVAL I AS LONG) AS LONG
    ' *************************************************************
    GLOBAL hForm1&    ' Dialog handle
    ' Global Handles for menus
    GLOBAL hForm1_Menu0&
    GLOBAL hForm1_Menu1&
    GLOBAL hForm1_Menu3&
    '
    GLOBAL hGraph AS LONG
    GLOBAL hDCg AS LONG
    GLOBAL memdc AS LONG
    GLOBAL hbit AS LONG
    '
    GLOBAL lfFont AS lOGFONT  ' Logfont structure
    GLOBAL LogPixelsY AS LONG ' pixels per inch of screen height
    GLOBAL LogPixelsX AS LONG ' pixels per inch of screen width
    GLOBAL XDialUn&,YDialUn&
    GLOBAL Rct AS RECT
    GLOBAL Ps AS PAINTSTRUCT  ' Paint structure
    GLOBAL hPen AS LONG
    GLOBAL hBrush AS LONG
    GLOBAL BrushArray() AS LONG
    GLOBAL Font1 AS LONG, Font2 AS LONG
    GLOBAL EX AS SINGLE,EY AS SINGLE,EZ AS SINGLE
    GLOBAL PPD AS SINGLE
    '
    ' *************************************************************
    '
    FUNCTION PBMAIN
        LOCAL Count&,I&
        LOCAL hDC AS LONG
        'Retrieves a handle of a display device context (DC) for the
        'client area of the specified window (here the desktop).
        hDC = GetDC(%HWND_DESKTOP)
        '
        'Retrieves device-specific information about the number
        'of pixels per logical inch along the screen height and width
        '(depends on screen resolution setting).
        'This is important to define appropriate font sizes.
        LogPixelsY  = GetDeviceCaps(hDC, %LOGPIXELSY)
        LogPixelsX  = GetDeviceCaps(hDC, %LOGPIXELSX)
        '
        ReleaseDC %HWND_DESKTOP, hDC
    
        ShowDialog_Form1 0
    
        ' Create a virtual window
        GetClientRect hGraph,Rct
        hDCg = GetDC(hGraph)
        memdc = CreateCompatibleDC(hDCg)
        hbit = CreateCompatibleBitmap(hDCg, Rct.nRight, Rct.nBottom)
        SelectObject memdc, hbit
        hBrush = GetStockObject(%WHITE_BRUSH)
        SelectObject memdc, hBrush
        PatBlt memdc, 0, 0, Rct.nRight, Rct.nBottom, %PATCOPY
    
        EX = 4:EY = 4: EZ = 30   ' Start position of eye (viewpoint)
        PPD = 12                 ' Projection plane distance
        REDIM BrushArray(24)
        FOR I&=0 TO 24
            BrushArray(I&)=CreateSolidBrush(gColor(I&))
        NEXT
        Font1=MakeFont(6,400,0,0,0,"Arial")
        Font2=MakeFont(8,400,0,0,0,"Arial")
        DO
            DIALOG DOEVENTS TO Count&
        LOOP UNTIL Count&=0
        FOR I&=0 TO 24
            DeleteObject BrushArray(I&)
        NEXT
        DeleteObject hBrush
        DeleteObject hPen
        DeleteObject Font1
        DeleteObject Font2
        DeleteDC memdc
        DeleteObject hbit
    END FUNCTION
    '
    ' *************************************************************
    SUB ShowDialog_Form1(BYVAL hParent&)
        LOCAL Style&, ExStyle& ,hCtl&
        LOCAL LabelStyle2&
        ' hParent& = 0 if no parent Dialog
        Style& = %WS_POPUP OR %DS_MODALFRAME OR %WS_CAPTION OR %WS_MINIMIZEBOX OR %WS_SYSMENU OR %DS_CENTER OR %WS_CLIPCHILDREN
        ' NB: the clipchildren style must be included
        ExStyle& = 0
        XDialUn&=392 :YDialUn&=260
        DIALOG NEW hParent&, "3D-Graphics Demonstration", 0, 0,XDialUn&,YDialUn&, Style&, ExStyle& TO hForm1&
        LabelStyle2& = %WS_CHILD OR %WS_VISIBLE OR %SS_GRAYFRAME OR %SS_LEFT
        ' NB: The grayframe style must be included
        CONTROL ADD LABEL, hForm1&, %FORM1_GRAPHLABEL, "",2,0,298,210, LabelStyle2&
        CONTROL HANDLE hForm1&, %FORM1_GRAPHLABEL TO hGraph ' handle for graphics window
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_LEFT, "Increase X (""&Left"")", 50, 215, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_RIGHT, "Decrease X (""&Right"")", 50, 232, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_UP, "Increase Y (""&Up"")", 135, 215, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_DOWN, "Decrease Y (""&Down"")", 135, 232, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_CLOSER, "Decrease Z (""&Forward"")", 220, 232, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_FARTHER, "Increase Z (""&Backward"")", 220, 215, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_MORE_PERSPEC, "I&ncrease Perspective", 305, 215, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_LESS_PERSPEC, "D&ecrease Perspective", 305, 232, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_ROT_LEFT, "Rotate Lef&t", 305, 162, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_ROT_RIGHT, "Rotate Ri&ght", 305, 179, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_ROT_STOP, "&Stop Rotation", 305, 196, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD LABEL, hForm1&,%FORM1_LABEL_VIEWPOINT,"Change Eye Position (Viewpoint):",9,215,34,38, _
        %WS_CHILD OR %WS_VISIBLE OR %SS_LEFT
        CONTROL ADD LABEL, hForm1&,%FORM1_LABEL_MOUSEINF, _
        "Change Viewpoint easily:"+$CRLF+$CRLF+"Left Mouse Button Down:"+$CRLF+"   |  : Move Up and Down"+$CRLF+" --- : Rotate Right and Left"+$CRLF+$CRLF+ _
        "Right Mouse Button Down:"+$CRLF+"   |  : Change Distance"+$CRLF+" --- : Change Perspective",305,70,80,90, _
        %WS_CHILD OR %WS_VISIBLE OR %SS_LEFT
    
        ' ---------------------------
        MENU NEW BAR TO hForm1_Menu0&
        ' ---------------------------
        MENU NEW POPUP TO hForm1_Menu1&
        MENU ADD POPUP, hForm1_Menu0& ,"E&xit", hForm1_Menu1&, %MF_ENABLED
        ' - - - - - - - - - - - - - -
        MENU ADD STRING, hForm1_Menu1&, "E&xit",  %Form1_EXIT, %MF_ENABLED
        '
        MENU NEW POPUP TO hForm1_Menu3&
        MENU ADD POPUP, hForm1_Menu0& ,"&Help", hForm1_Menu3&, %MF_ENABLED
        ' - - - - - - - - - - - - - -
        MENU ADD STRING, hForm1_Menu3&, "&Description of program",  %Form1_HELP1, %MF_ENABLED
        MENU ADD STRING, hForm1_Menu3&, "&About",  %Form1_ABOUT, %MF_ENABLED
        MENU ATTACH hForm1_Menu0&, hForm1&
        DIALOG SHOW MODELESS hForm1& , CALL Form1_DLGPROC
    END SUB
    ' ---------------------------------------------------------
    CALLBACK FUNCTION Form1_DLGPROC
        LOCAL Res AS LONG, Dist AS SINGLE
        LOCAL lpsz AS ASCIIZ * 255
        LOCAL Phi AS SINGLE, Sign AS SINGLE
        LOCAL XM AS LONG, YM AS LONG
        STATIC XMPrev AS LONG, YMPrev AS LONG
        STATIC RotFlag AS LONG
        STATIC MouseXY AS LONG, MouseStartFlag AS LONG
        SELECT CASE CBMSG
            CASE %WM_PAINT
                '
                CALL Make3Dstructure
                '
                SetTextAlign memdc,%TA_CENTER
                SelectObject memdc, Font1
                lpsz="La Grande Arche, La Défence, Paris - By Johan Otto von Spreckelsen"
                TextOut memdc, Rct.nRight/2,Rct.nBottom-17, lpsz, BYVAL LEN(lpsz)
                '
                SetTextAlign memdc,%TA_LEFT
                SelectObject memdc, Font2
                lpsz="Viewpoint:  X:"+FORMAT$(EX,"* ###.#")
                TextOut memdc,80,2, lpsz, BYVAL LEN(lpsz)
                lpsz="Y:"+FORMAT$(EY,"* ###.#")
                TextOut memdc,210,2, lpsz, BYVAL LEN(lpsz)
                lpsz="Z:"+FORMAT$(EZ,"* ###.#")
                TextOut memdc,270,2, lpsz, BYVAL LEN(lpsz)
                lpsz="Projection Plane Distance:"+FORMAT$(PPD,"* ##.#")
                TextOut memdc,330,2, lpsz, BYVAL LEN(lpsz)
                '
                BeginPaint CBHNDL, Ps
                '
                GetClientRect hGraph,Rct
                hDCg = GetDC(hGraph)
                '
                ' Copy virtual window onto screen.
                BitBlt hDCg,0,0, Rct.nRight, Rct.nBottom, memdc,0,0,%SRCCOPY
                '
                EndPaint CBHNDL, Ps
                ReleaseDC hGraph, hDCg
                '
                IF RotFlag <>0 THEN
                    IF ABS(EX)<0.00001 THEN EX=EX+SGN(EX)*0.00001
                    Dist=SQR(EX*EX + EZ*EZ)
                    Phi = CalculatePhi(EX,EZ) + 0.01 * RotFlag
                    EX = Dist * COS(Phi)
                    EZ = Dist * SIN(Phi)
                    Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                END IF
                '
                FUNCTION = 1
                '
            CASE %WM_LBUTTONDOWN
                RotFlag = 0
                MouseXY = 1
                FUNCTION = 1
    
            CASE %WM_LBUTTONUP
                MouseXY = 0
                MouseStartFlag = 0
                FUNCTION = 1
    
            CASE %WM_RBUTTONDOWN
                RotFlag = 0
                MouseXY = 2
                FUNCTION = 1
    
            CASE %WM_RBUTTONUP
                MouseXY = 0
                MouseStartFlag = 0
                FUNCTION = 1
    
            CASE %WM_MOUSEMOVE
                '
                IF MouseXY = 1 THEN ' Left mouse button pressed
                    XM = LOWRD(CBLPARAM)
                    YM = HIWRD(CBLPARAM)
                    IF MouseStartFlag = 0 THEN
                        XMPrev = XM
                        YMPrev = YM
                        MouseStartFlag = 1
                    END IF
                    IF XM <> XMPrev THEN ' Mouse moved horizontally. Rotate object.
                        IF ABS(EX)<0.00001 THEN EX=EX+SGN(EX)*0.00001
                        Dist=SQR(EX*EX + EZ*EZ)
                        Phi = CalculatePhi(EX,EZ) + (XM-XMPrev) * 0.015
                        EX = Dist * COS(Phi)
                        EZ = Dist * SIN(Phi)
                        XMPrev = XM
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                    END IF
                    IF YM <> YMPrev THEN ' Mouse moved vertically. Move object up or down
                        EY = EY - (YM-YMPrev) * 0.3
                        YMPrev = YM
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                    END IF
                END IF
                '
                IF MouseXY = 2 THEN ' Right mouse button pressed
                    XM = LOWRD(CBLPARAM)
                    YM = HIWRD(CBLPARAM)
                    IF MouseStartFlag = 0 THEN
                        XMPrev = XM
                        YMPrev = YM
                        MouseStartFlag = 1
                    END IF
                    '
                    IF XM <> XMPrev THEN ' Mouse moved horizontally. Change degree of perspective
                        IF (PPD > 4 AND XM > XMPrev) OR (PPD < 100 AND XM < XMPrev) THEN
                            PPD = PPD * (1 + (XMPrev-XM)*0.01)
                            EX=EX * (1 + (XMPrev-XM)*0.01)
                            EY=EY * (1 + (XMPrev-XM)*0.01)
                            EZ=EZ * (1 + (XMPrev-XM)*0.01)
                        END IF
                        XMPrev = XM
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                    END IF
                    '
                    IF YM <> YMPrev THEN ' Mouse moved vertically. Change distance to object
                        Dist=SQR(EX*EX+EY*EY+EZ*EZ)
                        IF (Dist/PPD > 2.5 AND YM > YMPrev) OR (Dist/PPD < 100 AND YM < YMPrev) THEN
                            EX=EX * (1 + (YMPrev-YM)*0.01)
                            EY=EY * (1 + (YMPrev-YM)*0.01)
                            EZ=EZ * (1 + (YMPrev-YM)*0.01)
                        END IF
                        YMPrev = YM
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                    END IF
                END IF
                FUNCTION = 1
            CASE %WM_COMMAND
                ' Process Messages to Controls that have no Callback Function
                ' and Process Messages to Menu Items
                SELECT CASE CBCTL
                    CASE  %Form1_EXIT
                        res&=MSGBOX ("Are you sure?",%MB_YESNO OR %MB_ICONQUESTION ,"End?")
                        IF res&=%IDYES THEN DIALOG END hForm1&
                    CASE  %Form1_HELP1
                        Form1_HELP1_Select
                    CASE %Form1_ABOUT
                        Form1_ABOUT_Select
                    CASE %FORM1_BUTTON_LEFT
                        IF EX < 1000 THEN
                            DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                            LOOP
                            EX=EX+ABS(EX)*.1+1
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_RIGHT
                        IF EX > -1000 THEN
                            DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                            LOOP
                            EX=EX-ABS(EX)*.1-1
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_UP
                        IF EY < 1000 THEN
                            DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                            LOOP
                            EY=EY+ABS(EY)*.1+1
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_DOWN
                        IF EY > -1000 THEN
                            DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                            LOOP
                            EY=EY-ABS(EY)*.1-1
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_CLOSER
                        IF EZ > -1000 THEN
                            DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                            LOOP
                            EZ=EZ-ABS(EZ)*.1-1
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_FARTHER
                        IF EZ < 1000 THEN
                            DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                            LOOP
                            EZ=EZ+ABS(EZ)*.1+1
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_MORE_PERSPEC
                        IF PPD > 4 THEN
                            PPD = PPD*.9
                            EX=EX*.9 : EY=EY*.9 : EZ=EZ*.9
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_LESS_PERSPEC
                        IF PPD < 100 THEN
                            PPD = PPD/.9
                            EX=EX/.9 : EY=EY/.9 : EZ=EZ/.9
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_ROT_LEFT
                        RotFlag = -1
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                    CASE %FORM1_BUTTON_ROT_RIGHT
                        RotFlag = 1
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                    CASE %FORM1_BUTTON_ROT_STOP
                        RotFlag = 0
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                    CASE ELSE
                END SELECT
            CASE ELSE
        END SELECT
    END FUNCTION
    ' ------------------------------------------------
    FUNCTION CalculatePhi(EX AS SINGLE, EZ AS SINGLE) AS SINGLE
        ' These corrections are needed to make Phi take a full
        ' circle i.e. 360 degrees.
        ' Without the corrections Phi will only vary 180 degrees
        ' (-90 to 90) corresponding to the range for arcus tangens (ATN).
        LOCAL Ph AS SINGLE
        IF ABS(EX) < EZ*1E-36! THEN EX = EZ*1E-36!
        Ph = ATN(EZ/EX)
        IF Ph < 0! THEN Ph=Ph+3.141593!
        IF EZ < 0! THEN Ph=Ph+3.141593!
        FUNCTION = Ph
    END FUNCTION
    ' ------------------------------------------------
    SUB Form1_HELP1_Select()
        LOCAL St AS STRING
        St ="3D-Graphics Demonstration Program."+$CRLF+$CRLF+ _
        "This program illustrates the drawing of three-dimensional objects on "+ _
        "the screen. It includes routines for not displaying surfaces and "+ _
        "edges which cannot be seen from the eye or viewpoint position. "+ _
        "A key point in the program is the concept of surface orientation. "+ _
        "The vertices (corners) of each surface unit (facet) must follow a "+ _
        "counter-clockwise sequence when seen from the outer side of the "+ _
        "surface. The object must be composed of convex facets. If you want "+ _
        "to show objects with concave facets such must first be broken down "+ _
        "to two or more convex facets. The coordinate system used is left- "+ _
        "hand orientated. For further background information you should "+ _
        "consult textbooks on computer graphics."+$CRLF+$CRLF+ _
        "The program allows you to change the eye (viewpoint) position "+ _
        "coordinates and the degree of perspective. You are always looking "+ _
        "toward the center (0,0,0) of the coordinate system. So it is best "+ _
        "if you place the object in such a way that its center is at 0,0,0. "+ _
        "PowerBasic's handy matrix functions are being used for "+ _
        "transformation of coordinates. You can make the object rotate "+ _
        "continuously left or right. The flicker has been reduced by making the "+ _
        "drawing in a virtual window. Repainting is done by copying the virtual "+ _
        "window to the screen window. This updating has been inspired by the "+ _
        "very fine contributions by the many experts in the Forum, whom I thank "+ _
        "very much. This late version allows you to move the object using the mouse "+ _
        "as long as the left mouse button is held down. Thanks to Brad Byrne for "+ _
        "suggesting this feature and to Todd Wasson for his code on 3-D vector "+ _
        "graphics which demonstrates how the viewpoint can be controlled by the "+ _
        "mouse. Also thanks to Karl Lessmann for his comments. Further suggestions "+ _
        "for improvement are still welcome."+$CRLF+$CRLF+ _
        "Best wishes"+$CRLF+$CRLF+ _
        "Erik Christensen ---- e.chr@email.dk"
        MSGBOX St,%MB_ICONINFORMATION,"Information"
    END SUB
    ' ------------------------------------------------
    SUB Form1_ABOUT_Select
        LOCAL St AS STRING
        St="Three-dimensional graphics demonstration program (version 1.3, April 7, 2002)"+$CRLF+$CRLF+ _
        "By Erik Christensen, Copenhagen, Denmark       e.chr@email.dk"+$CRLF+$CRLF+ _
        "The use of this Public Domain program and its consequences are your own responsibility. However, any comment you may have is welcome."+$CRLF+$CRLF+ _
        "Good Luck!"
        MSGBOX St,%MB_ICONINFORMATION,"About this program"
    END SUB
    ' ------------------------------------------------
    FUNCTION MakeFont(BYVAL FontTypeSize AS LONG,BYVAL FontWeight AS LONG, _
        BYVAL Italic AS LONG, BYVAL Underline AS LONG,BYVAL StrikeOut AS LONG, _
        BYVAL FaceName AS STRING) AS LONG
    ' -----------------------
        'TYPE LOGFONT defines the attributes of a font.
        'See LOGFONT in the Win32 help file
        lfFont.lfHeight = -MulDiv(FontTypeSize,LogPixelsY,72) ' better than: -(FontTypeSize * LogPixelsY) \ 72
                                                ' logical height of font
        lfFont.lfWidth = 0                      ' logical average character width
        lfFont.lfEscapement = 0                 ' angle of escapement
        lfFont.lfOrientation = 0                ' base-line orientation angle
        lfFont.lfWeight = FontWeight            ' font weight
        lfFont.lfItalic = Italic                ' italic attribute flag    (0,1)
        lfFont.lfUnderline = Underline          ' underline attribute flag (0,1)
        lfFont.lfStrikeOut = StrikeOut          ' strikeout attribute flag (0,1)
        lfFont.lfCharSet = %ANSI_CHARSET        ' character set identifier
        lfFont.lfOutPrecision = %OUT_TT_PRECIS  ' output precision
        lfFont.lfClipPrecision = %CLIP_DEFAULT_PRECIS  ' clipping precision
        lfFont.lfQuality = %DEFAULT_QUALITY     ' output quality
        lfFont.lfPitchAndFamily = %FF_DONTCARE  ' pitch and family
        lfFont.lfFaceName = FaceName            ' typeface name string
    ' -----------------------
        ' Make font according to specifications
        FUNCTION = CreateFontIndirect (lfFont)
    END FUNCTION
    ' ------------------------------------------------
    FUNCTION gColor(BYVAL I AS LONG) AS LONG
      SELECT CASE I
        ' Common RGB Colors:
        CASE 0 : FUNCTION = %BLACK       ' = &H000000??? (same as RGB(0,0,0))
        CASE 1 : FUNCTION = %BLUE        ' = &HFF0000???
        CASE 2 : FUNCTION = %GREEN       ' = &H00FF00???
        CASE 3 : FUNCTION = %CYAN        ' = &HFFFF00???
        CASE 4 : FUNCTION = %RED         ' = &H0000FF???
        CASE 5 : FUNCTION = %MAGENTA     ' = &HFF00FF???
        CASE 6 : FUNCTION = %YELLOW      ' = &H00FFFF???
        CASE 7 : FUNCTION = %WHITE       ' = &HFFFFFF??? (same as RGB(255,255,255))
        CASE 8 : FUNCTION = &H101010???  '   Gray - very very dark
        CASE 9 : FUNCTION = &H202020???  '   Gray - very dark
        CASE 10: FUNCTION = &H303030???  '   Gray - moderately to very dark
        CASE 11: FUNCTION = &H404040???  '   Gray - moderately dark
        CASE 12: FUNCTION = &H505050???  '   Gray - slightly to moderately dark
        CASE 13: FUNCTION = &H606060???  '   Gray - slightly dark
        CASE 14: FUNCTION = &H707070???  '   Gray - slightly dark to normal
        CASE 15: FUNCTION = %GRAY        ' = &H808080???  (normal gray)
        CASE 16: FUNCTION = &H909090???  '   Gray - slightly light to normal
        CASE 17: FUNCTION = &HA0A0A0???  '   Gray - slightly light
        CASE 18: FUNCTION = &HB0B0B0???  '   Gray - slightly to moderately light
        CASE 19: FUNCTION = %LTGRAY      ' = &HC0C0C0??? (moderately light gray)
        CASE 20: FUNCTION = &HD0D0D0???  '   Gray - moderately to very light
        CASE 21: FUNCTION = &HE0E0E0???  '   Gray - very light
        CASE 22: FUNCTION = &HF0F0F0???  '   Gray - very very light
        CASE 23: FUNCTION = &HF8F8F8???  '   Gray - nearly white
        CASE 24: FUNCTION = &HFCFCFC???  '   Gray - practically white
    
        ' Additional colors can be added e.g. using the RGB function,
        ' e.g. CASE 15: FUNCTION = RGB(X,Y,Z)
        ' and so on.
        CASE ELSE : FUNCTION = %BLACK
      END SELECT
    END FUNCTION
    ' ------------------------------------------------
    FUNCTION PenStyle(BYVAL I AS LONG) AS LONG
      SELECT CASE I
        CASE 0 :   FUNCTION = %PS_SOLID       '  _______
        CASE 1 :   FUNCTION = %PS_DASH        '  -------
        CASE 2 :   FUNCTION = %PS_DOT         '  .......
        CASE 3 :   FUNCTION = %PS_DASHDOT     '  _._._._
        CASE 4 :   FUNCTION = %PS_DASHDOTDOT  '  _.._.._
        CASE ELSE: FUNCTION = %PS_SOLID
      END SELECT
    END FUNCTION
    ' -------------------------------------------------------------------------
    ' The following routines have been heavily inspired by this very fine book:
    ' Ian. O. Angell. Advanced Graphics with the IBM Personal Computer.
    ' -------------------------------------------------------------------------
    SUB Make3Dstructure
        DIM X(16) AS SINGLE, Y(16) AS SINGLE, Z(16) AS SINGLE
        DIM XD(16) AS SINGLE, YD(16) AS SINGLE
        DIM Facet(4, 16) AS LONG, FacetColour(16) AS LONG, FacetCorners(16) AS LONG
        DIM A(1:4,1:4) AS SINGLE, R(1:4,1:4) AS SINGLE, Q(1:4,1:4) AS SINGLE
        DIM B(1:4,1:4) AS SINGLE
        LOCAL M&,I&,NOF&,NOV&
        LOCAL XX AS SINGLE, YY AS SINGLE, ZZ AS SINGLE
    
        ' Make virtual window white.
        hBrush = GetStockObject(%WHITE_BRUSH)
        SelectObject memdc, hBrush
        PatBlt memdc, 0, 0, Rct.nRight, Rct.nBottom, %PATCOPY
    
        NOF& = 16  ' Number of facets
        NOV& = 16  ' Number of vertices ("corners")
    
          ' Read x,y,z coordinates of each vertex ("corner") in the structure
          DATA   -2.138,-2.218,-2.24,  2.138,-2.218,-2.24,  2.138,2.218,-2.24,  -2.138,2.218,-2.24
          DATA   -2.138,-2.218,2.24,   2.138,-2.218,2.24,   2.138,2.218,2.24,   -2.138,2.218,2.24
          DATA   -1.487,-1.766,-1.3,   1.487,-1.766,-1.3,   1.487,1.766,-1.3,   -1.487,1.766,-1.3
          DATA   -1.487,-1.766,1.3,    1.487,-1.766,1.3,    1.487,1.766,1.3,    -1.487,1.766,1.3
    
          FOR I& = 1 TO NOV&
              INCR M&: X(I&)=VAL(READ$(M&))
              INCR M&: Y(I&)=VAL(READ$(M&))
              INCR M&: Z(I&)=VAL(READ$(M&))
          NEXT I&
    
          ' Read sequence of vertices of each facet.
          ' This sequence should be counter-clockwise
          ' when seen from the outside of the structure.
    
          DATA  4, 3, 7, 8,   1, 5, 6, 2,   2, 6, 7, 3,   5, 1, 4, 8
          DATA 11,12,16,15,   9,10,14,13,  10,11,15,14,  13,16,12, 9
          DATA  4,12,11, 3,   9, 1, 2,10,   2, 3,11,10,   1, 9,12, 4
          DATA 16, 8, 7,15,   5,13,14, 6,  15, 7, 6,14,   8,16,13, 5
    
          FOR I& = 1 TO NOF&
              INCR M&: Facet(1,I&)=VAL(READ$(M&))
              INCR M&: Facet(2,I&)=VAL(READ$(M&))
              INCR M&: Facet(3,I&)=VAL(READ$(M&))
              INCR M&: Facet(4,I&)=VAL(READ$(M&))
              FacetCorners(I&) = 4 ' Number of corners in facet
          NEXT I&
    
          ' Read color codes for facets
          DATA 24,16,23,23,18,22,20,20,21,23,22,22,21,23,22,22
    
          FOR I& = 1 TO NOF&
              INCR M&: FacetColour(I&)=VAL(READ$(M&))
          NEXT I&
    
         'move complete object into OBSERVED position.
         MAT R() = IDN
         CALL LookAtStructureFromViewpoint(A(),R(),B())
         'get screen coordinates.
         FOR M& = 1 TO NOV&
             XX = X(M&): YY = Y(M&): ZZ = Z(M&)
             X(M&) = R(1, 1) * XX + R(1, 2) * YY + R(1, 3) * ZZ + R(1, 4)
             Y(M&) = R(2, 1) * XX + R(2, 2) * YY + R(2, 3) * ZZ + R(2, 4)
             Z(M&) = R(3, 1) * XX + R(3, 2) * YY + R(3, 3) * ZZ + R(3, 4)
             XD(M&) = X(M&) * PPD / Z(M&)
             YD(M&) = Y(M&) * PPD / Z(M&)
         NEXT M&
    
         CALL DrawScreenPicture(NOF&,Facet(),XD(),YD(), _
                FacetCorners(),FacetColour(), _
                X(), Y(), Z(),PPD)
    END SUB
    ' ------------------------------------------------
    SUB LookAtStructureFromViewpoint(A() AS SINGLE,R() AS SINGLE,B() AS SINGLE)
         LOCAL DX AS SINGLE,DY AS SINGLE,DZ AS SINGLE
         LOCAL TX AS SINGLE,TY AS SINGLE,TZ AS SINGLE
         LOCAL FX AS SINGLE,FY AS SINGLE,FZ AS SINGLE
         LOCAL THETA AS SINGLE, AX AS SINGLE, AY AS SINGLE
         LOCAL AXIS&, DIST AS SINGLE
         LOCAL I&,J&,K&
         LOCAL t AS STRING,t2 AS STRING
         ' Eye position EX, EY, EZ - Global variables
         DX = 0: DY = 0: DZ = 0
         ' Move origin to (DX,DY,DZ).
         LET TX = -DX: LET TY = -DY: TZ = -DZ
         MAT A() = IDN : A(1, 4) = TX: A(2, 4) = TY: A(3, 4) = TZ
         MAT B() = A() * R() : MAT R() = B()
         ' Move eye onto negative z-axis, looking at origin.
         FX = EX - DX: FY = EY - DY: FZ = EZ - DZ
         AX = FX: AY = FY
         CALL ViewingAngle(AX, AY, THETA)
         THETA = -THETA:  AXIS& = 3
         CALL RotateSystem(THETA, AXIS,A())
         MAT B() = A() * R() : MAT R() = B()
         DIST = SQR(FX * FX + FY * FY)
         AX = FZ: AY = DIST
         CALL ViewingAngle(AX, AY, THETA)
         THETA = 3.141593 - THETA: AXIS& = 2
         CALL RotateSystem(THETA, AXIS,A())
         MAT B() = A() * R() : MAT R() = B()
         ' Maintain the vertical.
         TZ = SQR(DIST * DIST + FZ * FZ)
         AX = TZ * FX: AY = -FY * FZ
         CALL ViewingAngle(AX, AY, THETA)
         AXIS& = 3
         CALL RotateSystem(THETA, AXIS, A())
         MAT B() = A() * R() : MAT R() = B()
         ' Move the eye to the origin : space is now in OBSERVED position.
         R(3,4)=TZ
    END SUB
    ' ------------------------------------------------
    SUB RotateSystem(THETA AS SINGLE, AXIS AS LONG,A() AS SINGLE)
          LOCAL AX1&,AX2&,CT AS SINGLE, ST AS SINGLE
          MAT A() = ZER
          AX1& = (AXIS& MOD 3) + 1: AX2& = (AX1& MOD 3) + 1
          CT = COS(THETA): ST = SIN(THETA)
          A(AXIS&, AXIS&) = 1
          A(AX1&, AX1&) = CT: A(AX1&, AX2&) = -ST
          A(AX2&, AX1&) = ST: A(AX2&, AX2&) = CT
    END SUB
    ' ------------------------------------------------
    SUB ViewingAngle(AX AS SINGLE, AY AS SINGLE, THETA AS SINGLE)
           ' THETA is the angle that the line from origin to (AX,AY)
           ' makes with the positive x-axis.
           IF ABS(AX) > .000001 THEN ' Line is not vertical, so it has a finite tangent.
               THETA = ATN(AY / AX)
               IF AX < 0 THEN THETA = THETA + 3.141593
           ELSE ' Line is vertical.
               THETA = 3.141593 / 2
               IF AY < 0 THEN THETA = THETA + 3.141593
               IF ABS(AY) < .000001 THEN THETA = 0
           END IF
    END SUB
    ' ------------------------------------------------
    SUB DrawScreenPicture(NOF AS LONG,Facet() AS LONG,XD() AS SINGLE,YD() AS SINGLE, _
                FacetCorners() AS LONG,FacetColour() AS LONG, _
                X() AS SINGLE, Y() AS SINGLE, Z() AS SINGLE,PPD AS SINGLE)
          LOCAL HSIZ&,FREE&,NFREE&,NVIS&,I&,I1&,I2&,I3&,FA&,FB&
          LOCAL OVER&,FRONT&,BACK&
          LOCAL X1 AS SINGLE,X2 AS SINGLE,X3 AS SINGLE
          LOCAL Y1 AS SINGLE,Y2 AS SINGLE,Y3 AS SINGLE
          LOCAL DX1 AS SINGLE,DX2 AS SINGLE
          LOCAL DY1 AS SINGLE,DY2 AS SINGLE
          HSIZ& = NOF& * 3  ' Defines size of stack. Must not be too small.
          ' StackArray&(I&) and PointerArray&(I&) are the storage and pointer
          ' locations available for the construction of linked lists.
          ' LIS&(I&) points to a list af indices of facets that lie
          ' in front af facet I&.
          DIM G(NOF&) AS LONG, LIS(NOF&) AS LONG, StackArray(HSIZ&) AS LONG, PointerArray(HSIZ&) AS LONG
          ' FREE& points to a list of free storage locations available
          ' in the StackArray& (and PointerArray&) arrays.
          ' NVIS& is the number of anticlockwise and potentially visible facets.
          FREE& = 1: NVIS& = 0
          ' Initialise the PointerArray& pointers for the linked lists. Initially all the storage in StackArray& is FREE&.
          FOR I& = 1 TO HSIZ&
              PointerArray&(I&) = I& + 1
          NEXT I&
          ' Orientate the projected facets:
          ' G&(I&)=-1 means projected facet I& is clockwise
          ' G&(I&)=0 means it is anticlockwise and potentially visible.
          FOR I& = 1 TO NOF&
              I1& = Facet(1, I&): X1 = XD(I1&): Y1 = YD(I1&)
              I2& = Facet(2, I&): X2 = XD(I2&): Y2 = YD(I2&)
              I3& = Facet(3, I&): X3 = XD(I3&): Y3 = YD(I3&)
              DX1 = X2 - X1: DY1 = Y2 - Y1
              DX2 = X3 - X2: DY2 = Y3 - Y2
              IF DX1 * DY2 - DX2 * DY1 > 0 THEN G&(I&) = 0: NVIS& = NVIS& + 1: LIS&(I&) = 0 ELSE G&(I&) = -1
          NEXT I&
          ' Compare visible facets : FA& with FB&.
          ' G&(FA&) will now hold the number of facets not already
          ' drawn that will lie behind facet FA&.
          FOR FA& = 1 TO NOF& - 1
              IF G&(FA&) <> -1 THEN
                  FOR FB& = FA& + 1 TO NOF&
                      IF G&(FB&) <> -1 THEN
                          CALL CheckOverlapOfFacets(XD(),YD(),FacetCorners(), _
                               Facet(),FA&,FB&,OVER&,FRONT&,BACK&, _
                               X(),Y(),Z(),PPD)
                             ' If facets overlap i.e. facet FRONT& in front of facet
                             ' BACK& then increment G&(FRONT&), and add FRONT& to the list
                             ' of facets in front of facet BACK&. Adjust the StackArray&.
                          IF OVER& <> 0 THEN
                              G&(FRONT&) = G&(FRONT&) + 1: NFREE& = PointerArray&(FREE&)
                              StackArray&(FREE&) = FRONT&: PointerArray&(FREE&) = LIS&(BACK&)
                              LIS&(BACK&) = FREE&: FREE& = NFREE&
                          END IF
                      END IF
                  NEXT FB&
              END IF
          NEXT FA&
          ' Sort the network of linked lists of facets to be displayed.
          CALL SortFacetsAccordingToDistance(NOF&,Facet(),FacetCorners(), _
               FacetColour(),G(),NVIS&, XD(), _
               YD(),LIS(),StackArray(),PointerArray(),FREE&)
    END SUB
    ' ------------------------------------------------
    SUB CheckOverlapOfFacets(XD() AS SINGLE,YD() AS SINGLE,FacetCorners() AS LONG, _
                Facet() AS LONG,FA AS LONG,FB AS LONG, _
                OVER AS LONG, FRONT AS LONG,BACK AS LONG, _
                X() AS SINGLE, Y() AS SINGLE, Z() AS SINGLE,PPD AS SINGLE)
         LOCAL P1&,P2&,NA&,NB&,NF&,K&,M&,V&,V1&,V2&,V3&,NC&,S1&,S2&
         LOCAL X1 AS SINGLE,X2 AS SINGLE,Y1 AS SINGLE, Y2 AS SINGLE
         LOCAL CC AS SINGLE, CA AS SINGLE,CB AS SINGLE
         LOCAL XI1 AS SINGLE, YI1 AS SINGLE,XI2 AS SINGLE, YI2 AS SINGLE
         LOCAL VAL1 AS SINGLE, VAL2 AS SINGLE, A1 AS SINGLE,A2 AS SINGLE
         LOCAL MU AS SINGLE, UM AS SINGLE, DENOM AS SINGLE
         LOCAL MU1 AS SINGLE, MU2 AS SINGLE
         LOCAL XMID AS SINGLE, YMID AS SINGLE
         LOCAL DX1 AS SINGLE, DX3 AS SINGLE
         LOCAL DY1 AS SINGLE, DY3 AS SINGLE
         LOCAL DZ1 AS SINGLE, DZ3 AS SINGLE
         LOCAL A AS SINGLE, B AS SINGLE,C AS SINGLE,D AS SINGLE
         '
         ' the NA& vertices af facet FA& and the NB& vertices of facet FB&
         ' are obtained from array Facet().
         ' Polygons are stored in anticlockwise orientation.
         ' Check if the view of facets FA& and FB& overlap.
         ' OVER& is set to 1 if they do, and to 0 if they do not.
         P1& = 1: NA& = FacetCorners(FA&): NB& = FacetCorners(FB&): NF& = NA&
         DIM XF(2, NA& + NB&) AS SINGLE, YF(2, NA& + NB&) AS SINGLE
         ' Place projected view of facet FA& in the arrays
         ' XF(1,...) and YF(1,...).
         FOR K& = 1 TO NA&
             V& = Facet(K&, FA&): XF(1, K&) = XD(V&): YF(1, K&) = YD(V&)
         NEXT K&
         ' Use each edge line of facet FB& to slice off part of
         ' the polygon stored in XF,YF.
         ' Line joins point (X1,Y1) to (X2,Y2).
         V1& = Facet(NB&, FB&): X1 = XD(V1&):  Y1 = YD(V1&)
         FOR K& = 1 TO NB&
             V2& = Facet(K&, FB&): X2 = XD(V2&):  Y2 = YD(V2&)
             ' The line is CA.Y+CB.X+CC=0.
             CA = X2 - X1: CB = Y1 - Y2: CC = -X1 * CB - Y1 * CA
             ' Go round the NF& vertices in XF,YF. If positive relative to
             ' the line, then add point to new XF,YF set. If negative
             ' then ignore.
             P2& = 3 - P1&: XI1 = XF(P1&, NF&): YI1 = YF(P1&, NF&)
             VAL1 = CA * YI1 + CB * XI1 + CC: A1 = ABS(VAL1): NC& = 0
             IF A1 < .000001 THEN S1& = 0 ELSE S1& = SGN(VAL1)
             FOR M& = 1 TO NF&
                 XI2 = XF(P1&, M&): YI2 = YF(P1&, M&)
                 VAL2 = CA * YI2 + CB * XI2 + CC: A2 = ABS(VAL2)
                 IF A2 < .000001 THEN S2& = 0 ELSE S2& = SGN(VAL2)
                 IF S1& >= 0 THEN NC& = NC& + 1: XF(P2&, NC&) = XI1: YF(P2&, NC&) = YI1
                 IF S1& <> S2& AND S1& <> 0 AND S2& <> 0 THEN
                     ' If there is an intersection then also add to new XF,YF arrays.
                     MU = A1: UM = A2: DENOM = A1 + A2: NC& = NC& + 1
                     XF(P2&, NC&) = (UM * XI1 + MU * XI2) / DENOM: YF(P2&, NC&) = (UM * YI1 + MU * YI2) / DENOM
                 END IF
                 VAL1 = VAL2: S1& = S2&: A1 = A2: XI1 = XI2: YI1 = YI2
             NEXT M&
             ' If facets do not overlap then OVER&=0.
             IF NC& < 3 THEN OVER& = 0: EXIT SUB
             NF& = NC&: P1& = P2&: X1 = X2: Y1 = Y2
         NEXT K&
         ' Find (XMID,YMID) common to both projected facets.
         XMID = (XF(P1&, 1) + XF(P1&, 2) + XF(P1&, 3)) / 3
         YMID = (YF(P1&, 1) + YF(P1&, 2) + YF(P1&, 3)) / 3
         V1& = Facet(1, FA&): V2& = Facet(2, FA&):  V3& = Facet(3, FA&)
         GOSUB Distance : MU1 = MU2 ' Get distance MU1
         ' MU1 is the distance of the eye from that point
         ' on facet FA& which is projected into (XMID,YMID).
         V1& = Facet(1, FB&): V2& = Facet(2, FB&): V3& = Facet(3, FB&)
         GOSUB Distance             ' Get distance MU2
         ' MU2 is the distance of the eye from that point
         ' on facet FB which is projected into (XMID,YMID).
         '
         ' Ff MU1>MU2 then facet FB& is closer to the eye, that is
         ' facet FB& is in front af facet FA&. Similarly if MU1<MU2.
         OVER& = 1
         IF MU1 > MU2 THEN FRONT& = FB&: BACK& = FA& ELSE FRONT& = FA&: BACK& = FB&
         EXIT SUB
         '
         Distance:
             DX1 = X(V1&) - X(V2&): DX3 = X(V3&) - X(V2&)
             DY1 = Y(V1&) - Y(V2&): DY3 = Y(V3&) - Y(V2&)
             DZ1 = Z(V1&) - Z(V2&): DZ3 = Z(V3&) - Z(V2&)
             A = DY1 * DZ3 - DY3 * DZ1: B = DZ1 * DX3 - DZ3 * DX1: C = DX1 * DY3 - DX3 * DY1
             D = A * X(V1&) + B * Y(V1&) + C * Z(V1&)
             MU2 = D / (A * XMID + B * YMID + C * PPD)
         RETURN
    END SUB
    ' ------------------------------------------------
    SUB SortFacetsAccordingToDistance(NOF AS LONG,Facet() AS LONG,FacetCorners() AS LONG, _
                FacetColour() AS LONG,G() AS LONG,NVIS AS LONG, XD() AS SINGLE, _
                YD() AS SINGLE,LIS() AS LONG,StackArray() AS LONG,PointerArray() AS LONG,FREE AS LONG)
           LOCAL StackPosition&,F&,ValueIn&,ValueOut&,NC&,COLFAC&,I&,V&,PT&,F2&
           StackPosition& = 0
           DIM XC(10) AS SINGLE, YC(10) AS SINGLE
           ' Create a stack. Push on it all facets F& that have
           ' no facets behind them i.e. G&(F&)=0
           FOR F& = 1 TO NOF&
               IF G&(F&) = 0 THEN ValueIn& = F&: CALL PushValueOntoStack(ValueIn,FREE,StackPosition,PointerArray(),StackArray())
           NEXT F&
           ' Find an order for drawing all the visible facets
           ' so that hidden sections are obliterated. Draw
           ' facets that have no undrawn facets behind them.
           FOR F& = 1 TO NVIS&
               ' Pop a facet which has no undrawn facet behind it.
               CALL PopValueFromTopOfStack(ValueOut,FREE,StackPosition,PointerArray(),StackArray())
               ' If no facet is available, there is an error in the data.
               IF ValueOut& = 0 THEN MSGBOX "Error in the data - network has a cycle"': STOP
               ' Draw the facet.
               NC& = FacetCorners(ValueOut&): COLFAC& = FacetColour(ValueOut&)
               FOR I& = 1 TO NC&
                   V& = Facet(I&, ValueOut&): XC(I&) = XD(V&): YC(I&) = YD(V&)
               NEXT I&
               CALL DrawThisFacet(NC&,XC(),YC(),COLFAC&)
               ' After the facet is drawn, adjust the values of array G&.
               ' Use the list LIS& to find facets in front of last facet drawn.
               ' Now G&(F&) holds the number of undrawn facets behind facet F&
               PT& = LIS&(ValueOut&)
               DO UNTIL PT& = 0
                   F2& = StackArray&(PT&)
                   G&(F2&) = G&(F2&) - 1
                   ' If facet F2& has no undrawn facet behind it, push it on stack
                   IF G&(F2&) = 0 THEN ValueIn& = F2&: CALL PushValueOntoStack(ValueIn,FREE,StackPosition,PointerArray(),StackArray())
                   PT& = PointerArray&(PT&)
               LOOP
           NEXT F&
    END SUB
    ' ------------------------------------------------
    SUB DrawThisFacet(NC AS LONG,XC() AS SINGLE,YC() AS SINGLE,COLFAC AS LONG)
        DIM pxy(0:10) AS POINTAPI
        LOCAL Res&
        LOCAL V&
        ' Fill points array with data adapted for graphics window dimensions
        FOR V& = 1 TO NC&
            pxy(V&-1).x=XC(V&)*Rct.nRight*0.25 + Rct.nRight * 0.5
            pxy(V&-1).y=Rct.nBottom-(YC(V&)*Rct.nBottom*0.3+Rct.nBottom*0.5)
        NEXT V&
        pxy(NC&).x=XC(1)*Rct.nRight*0.25 + Rct.nRight * 0.5
        pxy(NC&).y=Rct.nBottom-(YC(1)*Rct.nBottom*0.3+Rct.nBottom * 0.5)
        '
        hBrush = SelectObject(memdc,BrushArray(COLFAC&))
        ' Draw polygon in selected color
        Res&=Polygon(BYVAL memdc,pxy(0),BYVAL NC&)
        ' hPen = SelectObject(memdc, CreatePen(PenStyle(0), 0, gColor(0)))
        ' Draw outline of polygon in black. Uses default pen color and style: black and solid
        Res&=Polyline(BYVAL memdc,pxy(0), BYVAL (NC&+1))
    END SUB
    ' ------------------------------------------------
    SUB PushValueOntoStack(ValueIn AS LONG,FREE AS LONG,StackPosition AS LONG,PointerArray() AS LONG,StackArray() AS LONG) '&'8000  'push ' s 226
        LOCAL NF&
        NF& = FREE&                         ' Free position in stack.
        StackArray&(NF&) = ValueIn&         ' Put value onto stack in free position.
        FREE& = PointerArray&(FREE&)        ' New free position in stack.
        PointerArray&(NF&) = StackPosition& ' Update pointer array
        StackPosition& = NF&                ' New top position in stack
    END SUB
    ' ------------------------------------------------
    SUB PopValueFromTopOfStack(ValueOut AS LONG,FREE AS LONG,StackPosition AS LONG,PointerArray() AS LONG,StackArray() AS LONG) '8100  'pop ' s 226
        LOCAL NF&
        NF& = StackPosition&                ' Position of top item in stack.
        ValueOut& = StackArray&(NF&)        ' Get value out from this position.
        StackPosition& = PointerArray&(NF&) ' New top position in stack.
        PointerArray&(NF&) = FREE&          ' Update pointer array.
        FREE& = NF&                         ' New free position in stack.
    END SUB
    ' ------------------------------------------------
    [This message has been edited by Erik Christensen (edited August 21, 2003).]

    Comment


    • #3
      ' This is an update, which can also work on PBwin10.
      Code:
      ' This is an update, which can also work on PBwin10. :)
      #COMPILE EXE
      #DIM ALL
      
      #INCLUDE "win32api.inc"
      ' ----------------------------------------------------------
      %Form1_FILE                                     = 500
      ' ----------------------------------------------------------
      %Form1_EXIT                                     = 525
      ' ----------------------------------------------------------
      %FORM1_LABEL_VIEWPOINT       = 100
      %FORM1_LABEL_MOUSEINF        = 102
      %FORM1_GRAPHLABEL            = 105
      %FORM1_BUTTON_UP             = 110
      %FORM1_BUTTON_DOWN           = 115
      %FORM1_BUTTON_LEFT           = 120
      %FORM1_BUTTON_RIGHT          = 125
      %FORM1_BUTTON_CLOSER         = 130
      %FORM1_BUTTON_FARTHER        = 135
      %FORM1_BUTTON_MORE_PERSPEC   = 140
      %FORM1_BUTTON_LESS_PERSPEC   = 145
      %FORM1_BUTTON_ROT_LEFT       = 150
      %FORM1_BUTTON_ROT_RIGHT      = 155
      %FORM1_BUTTON_ROT_STOP       = 160
      %FORM1_TEXTBOX               = 165
      ' --------------------------------------------------
      GLOBAL hForm1&    ' Dialog handle
      ' Global Handles for menus
      GLOBAL hForm1_Menu0&
      GLOBAL hForm1_Menu1&
      '
      GLOBAL hGraph AS LONG
      GLOBAL hDCg AS LONG
      GLOBAL memdc AS LONG
      GLOBAL hbit AS LONG
      '
      GLOBAL Rct AS RECT
      GLOBAL Ps AS PAINTSTRUCT  ' Paint structure
      GLOBAL hPen AS LONG
      GLOBAL hBrush AS LONG
      GLOBAL BrushArray() AS LONG
      GLOBAL Font1 AS LONG, Font2 AS LONG
      GLOBAL EX AS SINGLE,EY AS SINGLE,EZ AS SINGLE
      GLOBAL PPD AS SINGLE
      '
      ' *************************************************************
      '
      FUNCTION PBMAIN
          LOCAL Count&,I&
          LOCAL hDC AS LONG
          'Retrieves a handle of a display device context (DC) for the
          'client area of the specified window (here the desktop).
          hDC = GetDC(%HWND_DESKTOP)
          '
          ReleaseDC %HWND_DESKTOP, hDC
      
          Font1 = CreateFont(15,0,0,0,400,0,0,0,0,3,2,1,82,"Arial")
          Font2 = CreateFont(15,0,0,0,400,0,0,0,0,3,2,1,82,"Courier New")
      
          ShowDialog_Form1 0
      
          ' Create a virtual window
          GetClientRect hGraph,Rct
          hDCg = GetDC(hGraph)
          memdc = CreateCompatibleDC(hDCg)
          hbit = CreateCompatibleBitmap(hDCg, Rct.nRight, Rct.nBottom)
          SelectObject memdc, hbit
          hBrush = GetStockObject(%WHITE_BRUSH)
          SelectObject memdc, hBrush
          PatBlt memdc, 0, 0, Rct.nRight, Rct.nBottom, %PATCOPY
      
          EX = 4:EY = 4: EZ = 30   ' Start position of eye (viewpoint)
          PPD = 12                 ' Projection plane distance
          REDIM BrushArray(25)
          FOR I&=0 TO 25
              BrushArray(I&)=CreateSolidBrush(gColor(I&))
          NEXT
          DO
              DIALOG DOEVENTS TO Count&
          LOOP UNTIL Count&=0
          FOR I&=0 TO 25
              DeleteObject BrushArray(I&)
          NEXT
          DeleteObject hBrush
          DeleteObject hPen
          DeleteObject Font1
          DeleteObject Font2
          DeleteDC memdc
          DeleteObject hbit
      END FUNCTION
      '
      ' *************************************************************
      SUB ShowDialog_Form1(BYVAL hParent&)
          LOCAL Style&, ExStyle& ,hCtl&
          LOCAL LabelStyle2&
          Style& = %WS_POPUP OR %DS_MODALFRAME OR %WS_CAPTION OR %WS_MINIMIZEBOX OR %WS_SYSMENU OR %DS_CENTER OR %WS_CLIPCHILDREN
          ' NB: the clipchildren style must be included
          ExStyle& = 0
          DIALOG NEW PIXELS, hParent&, "3D-Graphics Demonstration", 0, 0, 800, 520, Style&, ExStyle& TO hForm1&
          LabelStyle2& = %WS_CHILD OR %WS_VISIBLE OR %SS_GRAYFRAME OR %SS_LEFT
          ' NB: The grayframe style must be included
          CONTROL ADD LABEL, hForm1&, %FORM1_GRAPHLABEL, "",2*2, 0*2, 298*2, 210*2, LabelStyle2&
          CONTROL HANDLE hForm1&, %FORM1_GRAPHLABEL TO hGraph ' handle for graphics window
          CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_LEFT, "Move Left", 50*2, 215*2, 80*2, 14*2, _
          %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
          CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_RIGHT, "Move Right", 50*2, 232*2, 80*2, 14*2, _
          %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
          CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_UP, "Move Up", 135*2, 215*2, 80*2, 14*2, _
          %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
          CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_DOWN, "Move Down", 135*2, 232*2, 80*2, 14*2, _
          %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
          CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_CLOSER, "Move Forward", 220*2, 232*2, 80*2, 14*2, _
          %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
          CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_FARTHER, "Move Backward", 220*2, 215*2, 80*2, 14*2, _
          %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
          CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_MORE_PERSPEC, "I&ncrease Perspective", 305*2, 215*2, 80*2, 14*2, _
          %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
          CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_LESS_PERSPEC, "D&ecrease Perspective", 305*2, 232*2, 80*2, 14*2, _
          %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
          CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_ROT_LEFT, "Rotate Lef&t", 305*2, 162*2, 80*2, 14*2, _
          %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
          CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_ROT_RIGHT, "Rotate Ri&ght", 305*2, 179*2, 80*2, 14*2, _
          %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
          CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_ROT_STOP, "&Stop Rotation", 305*2, 196*2, 80*2, 14*2, _
          %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
          CONTROL ADD LABEL, hForm1&,%FORM1_LABEL_VIEWPOINT,"Change Eye Position (Viewpoint):",9*2,215*2,34*2,38*2, _
          %WS_CHILD OR %WS_VISIBLE OR %SS_LEFT
          CONTROL ADD LABEL, hForm1&,%FORM1_LABEL_MOUSEINF, _
          " Change Viewpoint easily:"+$CRLF+$CRLF+" Left Mouse Button Down:"+$CRLF+"   |  : Move Up or Down"+$CRLF+" --- : Move Right or Left"+$CRLF+$CRLF+ _
          " Right Mouse Button Down:"+$CRLF+"   |  : Move Forward or Backward"+$CRLF+" --- : Increase or Decrease Perspective",603,200,97*2,60*2, _
          %WS_CHILD OR %WS_VISIBLE OR %SS_LEFT OR %WS_BORDER
          CONTROL SET COLOR hForm1&,%FORM1_LABEL_MOUSEINF, %BLACK, RGB(255,255,180)
      
          CONTROL ADD TEXTBOX, hForm1&,%FORM1_TEXTBOX, "",603, 0, 194, 195, _
          %WS_TABSTOP OR %WS_CHILD OR %WS_VISIBLE OR %WS_VSCROLL OR %ES_MULTILINE OR %ES_READONLY, %WS_EX_CLIENTEDGE
          CONTROL SET COLOR hForm1&,%FORM1_TEXTBOX, %BLACK, RGB(180, 255, 180)
      
          LOCAL s AS STRING
          S ="3D-Graphics Demonstration Program."+$CRLF+$CRLF+ _
          "This program illustrates the drawing of three-dimensional objects on "+ _
          "the screen. It includes routines for not displaying surfaces and "+ _
          "edges which cannot be seen from the eye or viewpoint position. "+ _
          "A key point in the program is the concept of surface orientation. "+ _
          "The vertices (corners) of each surface unit (facet) must follow a "+ _
          "counter-clockwise sequence when seen from the outer side of the "+ _
          "surface. The object must be composed of convex facets. If you want "+ _
          "to show objects with concave facets such must first be broken down "+ _
          "to two or more convex facets. The coordinate system used is left- "+ _
          "hand orientated. For further background information you should "+ _
          "consult textbooks on computer graphics."+$CRLF+$CRLF+ _
          "The program allows you to change the eye (viewpoint) position "+ _
          "coordinates and the degree of perspective. You are always looking "+ _
          "toward the center (0,0,0) of the coordinate system. So it is best "+ _
          "if you place the object in such a way that its center is at 0,0,0. "+ _
          "PowerBasic's handy matrix functions are being used for "+ _
          "transformation of coordinates. You can make the object rotate "+ _
          "continuously left or right. The flicker has been reduced by making the "+ _
          "drawing in a virtual window. Repainting is done by copying the virtual "+ _
          "window to the screen window. This updating has been inspired by the "+ _
          "very fine contributions by the many experts in the Forum, whom I thank "+ _
          "very much. This late version allows you to move the object using the mouse "+ _
          "as long as the left mouse button is held down. Thanks to Brad Byrne for "+ _
          "suggesting this feature and to Todd Wasson for his code on 3-D vector "+ _
          "graphics, which demonstrates how the viewpoint can be controlled by the "+ _
          "mouse. Also thanks to Karl Lessmann for his comments. Further suggestions "+ _
          "for improvement are still welcome."+$CRLF+$CRLF+ _
          "The present version is updated for PBwin10." +$CRLF+$CRLF+ _
          "Best wishes"+$CRLF+$CRLF+ _
          "Erik Christensen"
           CONTROL SET TEXT hForm1&,%FORM1_TEXTBOX, S
      
          ' ---------------------------
          MENU NEW BAR TO hForm1_Menu0&
          ' ---------------------------
          MENU NEW POPUP TO hForm1_Menu1&
          MENU ADD POPUP, hForm1_Menu0& ,"E&xit", hForm1_Menu1&, %MF_ENABLED
          ' - - - - - - - - - - - - - -
          MENU ADD STRING, hForm1_Menu1&, "E&xit",  %Form1_EXIT, %MF_ENABLED
          '
          MENU ATTACH hForm1_Menu0&, hForm1&
          DIALOG SHOW MODELESS hForm1& , CALL Form1_DLGPROC
      END SUB
      ' ---------------------------------------------------------
      CALLBACK FUNCTION Form1_DLGPROC
          LOCAL RES AS LONG, Dist AS SINGLE
          LOCAL lpsz AS ASCIIZ * 255
          LOCAL Phi AS SINGLE, Sign AS SINGLE
          LOCAL XM AS LONG, YM AS LONG
          STATIC XMPrev AS LONG, YMPrev AS LONG
          STATIC RotFlag AS LONG
          STATIC MouseXY AS LONG, MouseStartFlag AS LONG
          SELECT CASE CBMSG
              CASE %WM_PAINT
                  '
                  CALL Make3Dstructure
                  '
                  SetTextAlign memdc,%TA_CENTER
                  SelectObject memdc, Font1
                  lpsz=" La Grande Arche, La Défence, Paris - By Johan Otto von Spreckelsen "
                  TextOut memdc, Rct.nRight/2,Rct.nBottom-17, lpsz, BYVAL LEN(lpsz)
                  '
                  SelectObject memdc, Font2
                  lpsz=" Viewpoint:  X:"+FORMAT$(EX,"* ##.0")+"   Y:"+FORMAT$(EY,"* ##.0")+"   Z:"+FORMAT$(EZ,"* ##.0")+"   Projection Plane Distance:"+FORMAT$(PPD,"* ##.0")+" "
                  TextOut memdc,Rct.nRight/2,2, lpsz, BYVAL LEN(lpsz)
                  '
                  BeginPaint CBHNDL, Ps
                  '
                  GetClientRect hGraph,Rct
                  hDCg = GetDC(hGraph)
                  '
                  ' Copy virtual window onto screen.
                  BitBlt hDCg,0,0, Rct.nRight, Rct.nBottom, memdc,0,0,%SRCCOPY
                  '
                  EndPaint CBHNDL, Ps
                  ReleaseDC hGraph, hDCg
                  '
                  IF RotFlag <>0 THEN
                      IF ABS(EX)<0.00001 THEN EX=EX+SGN(EX)*0.00001
                      Dist=SQR(EX*EX + EZ*EZ)
                      Phi = CalculatePhi(EX,EZ) + 0.01 * RotFlag
                      EX = Dist * COS(Phi)
                      EZ = Dist * SIN(Phi)
                      SLEEP 4 ' you may make the rotation slower or faster by increasing or decreasing the sleeping time
                  END IF
                  Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                  '
                  FUNCTION = 1
                  '
              CASE %WM_LBUTTONDOWN
                  RotFlag = 0
                  MouseXY = 1
                  FUNCTION = 1
      
              CASE %WM_LBUTTONUP
                  MouseXY = 0
                  MouseStartFlag = 0
                  FUNCTION = 1
      
              CASE %WM_RBUTTONDOWN
                  RotFlag = 0
                  MouseXY = 2
                  FUNCTION = 1
      
              CASE %WM_RBUTTONUP
                  MouseXY = 0
                  MouseStartFlag = 0
                  FUNCTION = 1
      
              CASE %WM_MOUSEMOVE
                  '
                  IF MouseXY = 1 THEN ' Left mouse button pressed
                      XM = LOWRD(CBLPARAM)
                      YM = HIWRD(CBLPARAM)
                      IF MouseStartFlag = 0 THEN
                          XMPrev = XM
                          YMPrev = YM
                          MouseStartFlag = 1
                      END IF
                      IF XM <> XMPrev THEN ' Mouse moved horizontally. Rotate object.
                          IF ABS(EX)<0.00001 THEN EX=EX+SGN(EX)*0.00001
                          Dist=SQR(EX*EX + EZ*EZ)
                          Phi = CalculatePhi(EX,EZ) + (XM-XMPrev) * 0.015
                          EX = Dist * COS(Phi)
                          EZ = Dist * SIN(Phi)
                          XMPrev = XM
                          Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                      END IF
                      IF YM <> YMPrev THEN ' Mouse moved vertically. Move object up or down
                          EY = EY - (YM-YMPrev) * 0.3
                          YMPrev = YM
                          Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                      END IF
                  END IF
                  '
                  IF MouseXY = 2 THEN ' Right mouse button pressed
                      XM = LOWRD(CBLPARAM)
                      YM = HIWRD(CBLPARAM)
                      IF MouseStartFlag = 0 THEN
                          XMPrev = XM
                          YMPrev = YM
                          MouseStartFlag = 1
                      END IF
                      '
                      IF XM <> XMPrev THEN ' Mouse moved horizontally. Change degree of perspective
                          IF (PPD > 4 AND XM > XMPrev) OR (PPD < 100 AND XM < XMPrev) THEN
                              PPD = PPD * (1 + (XMPrev-XM)*0.01)
                              EX=EX * (1 + (XMPrev-XM)*0.01)
                              EY=EY * (1 + (XMPrev-XM)*0.01)
                              EZ=EZ * (1 + (XMPrev-XM)*0.01)
                          END IF
                          XMPrev = XM
                          Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                      END IF
                      '
                      IF YM <> YMPrev THEN ' Mouse moved vertically. Change distance to object
                          Dist=SQR(EX*EX+EY*EY+EZ*EZ)
                          IF (Dist/PPD > 2.5 AND YM > YMPrev) OR (Dist/PPD < 100 AND YM < YMPrev) THEN
                              EX=EX * (1 + (YMPrev-YM)*0.01)
                              EY=EY * (1 + (YMPrev-YM)*0.01)
                              EZ=EZ * (1 + (YMPrev-YM)*0.01)
                          END IF
                          YMPrev = YM
                          Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                      END IF
                  END IF
                  FUNCTION = 1
              CASE %WM_COMMAND
                  ' Process Messages to Controls that have no Callback Function
                  ' and Process Messages to Menu Items
                  SELECT CASE CBCTL
                      CASE  %Form1_EXIT
                          DIALOG END hForm1&
                      CASE %FORM1_BUTTON_LEFT
                          IF EX < 1000 THEN
                              DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                  EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                              LOOP
                              EX=EX+ABS(EX)*.1+1
                              Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                          END IF
                          RotFlag = 0
                      CASE %FORM1_BUTTON_RIGHT
                          IF EX > -1000 THEN
                              DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                  EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                              LOOP
                              EX=EX-ABS(EX)*.1-1
                              Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                          END IF
                          RotFlag = 0
                      CASE %FORM1_BUTTON_UP
                          IF EY < 1000 THEN
                              DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                  EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                              LOOP
                              EY=EY+ABS(EY)*.1+1
                              Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                          END IF
                          RotFlag = 0
                      CASE %FORM1_BUTTON_DOWN
                          IF EY > -1000 THEN
                              DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                  EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                              LOOP
                              EY=EY-ABS(EY)*.1-1
                              Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                          END IF
                          RotFlag = 0
                      CASE %FORM1_BUTTON_CLOSER
                          IF EZ > -1000 THEN
                              DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                  EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                              LOOP
                              EZ=EZ-ABS(EZ)*.1-1
                              Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                          END IF
                          RotFlag = 0
                      CASE %FORM1_BUTTON_FARTHER
                          IF EZ < 1000 THEN
                              DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                  EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                              LOOP
                              EZ=EZ+ABS(EZ)*.1+1
                              Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                          END IF
                          RotFlag = 0
                      CASE %FORM1_BUTTON_MORE_PERSPEC
                          IF PPD > 4 THEN
                              PPD = PPD*.9
                              EX=EX*.9 : EY=EY*.9 : EZ=EZ*.9
                              Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                          END IF
                          RotFlag = 0
                      CASE %FORM1_BUTTON_LESS_PERSPEC
                          IF PPD < 100 THEN
                              PPD = PPD/.9
                              EX=EX/.9 : EY=EY/.9 : EZ=EZ/.9
                              Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                          END IF
                          RotFlag = 0
                      CASE %FORM1_BUTTON_ROT_LEFT
                          RotFlag = -1
                          Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                      CASE %FORM1_BUTTON_ROT_RIGHT
                          RotFlag = 1
                          Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                      CASE %FORM1_BUTTON_ROT_STOP
                          RotFlag = 0
                          Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                      CASE ELSE
                  END SELECT
              CASE ELSE
          END SELECT
      END FUNCTION
      ' ------------------------------------------------
      FUNCTION CalculatePhi(EX AS SINGLE, EZ AS SINGLE) AS SINGLE
          ' These corrections are needed to make Phi take a full
          ' circle i.e. 360 degrees.
          ' Without the corrections Phi will only vary 180 degrees
          ' (-90 to 90) corresponding to the range for arcus tangens (ATN).
          LOCAL Ph AS SINGLE
          IF ABS(EX) < EZ*1E-36! THEN EX = EZ*1E-36!
          Ph = ATN(EZ/EX)
          IF Ph < 0! THEN Ph=Ph+3.141593!
          IF EZ < 0! THEN Ph=Ph+3.141593!
          FUNCTION = Ph
      END FUNCTION
      ' ------------------------------------------------
      FUNCTION gColor(BYVAL I AS LONG) AS LONG
        SELECT CASE I
          ' Common RGB Colors:
          CASE 0 : FUNCTION = %BLACK       ' = &H000000??? (same as RGB(0,0,0))
          CASE 1 : FUNCTION = %BLUE        ' = &HFF0000???
          CASE 2 : FUNCTION = %GREEN       ' = &H00FF00???
          CASE 3 : FUNCTION = %CYAN        ' = &HFFFF00???
          CASE 4 : FUNCTION = %RED         ' = &H0000FF???
          CASE 5 : FUNCTION = %MAGENTA     ' = &HFF00FF???
          CASE 6 : FUNCTION = %YELLOW      ' = &H00FFFF???
          CASE 7 : FUNCTION = %WHITE       ' = &HFFFFFF??? (same as RGB(255,255,255))
          CASE 8 : FUNCTION = &H101010???  '   Gray - very very dark
          CASE 9 : FUNCTION = &H202020???  '   Gray - very dark
          CASE 10: FUNCTION = &H303030???  '   Gray - moderately to very dark
          CASE 11: FUNCTION = &H404040???  '   Gray - moderately dark
          CASE 12: FUNCTION = &H505050???  '   Gray - slightly to moderately dark
          CASE 13: FUNCTION = &H606060???  '   Gray - slightly dark
          CASE 14: FUNCTION = &H707070???  '   Gray - slightly dark to normal
          CASE 15: FUNCTION = %GRAY        ' = &H808080???  (normal gray)
          CASE 16: FUNCTION = &H909090???  '   Gray - slightly light to normal
          CASE 17: FUNCTION = &HA0A0A0???  '   Gray - slightly light
          CASE 18: FUNCTION = &HB0B0B0???  '   Gray - slightly to moderately light
          CASE 19: FUNCTION = %LTGRAY      ' = &HC0C0C0??? (moderately light gray)
          CASE 20: FUNCTION = &HD0D0D0???  '   Gray - moderately to very light
          CASE 21: FUNCTION = &HE0E0E0???  '   Gray - very light
          CASE 22: FUNCTION = &HF0F0F0???  '   Gray - very very light
          CASE 23: FUNCTION = &HF8F8F8???  '   Gray - nearly white
          CASE 24: FUNCTION = &HFCFCFC???  '   Gray - practically white
          CASE 25: FUNCTION = %RGB_POWDERBLUE
      
          ' Additional colors can be added e.g. using the RGB function,
          ' e.g. CASE 26: FUNCTION = RGB(X,Y,Z)
          ' and so on.
          CASE ELSE : FUNCTION = %BLACK
        END SELECT
      END FUNCTION
      ' ------------------------------------------------
      FUNCTION PenStyle(BYVAL I AS LONG) AS LONG
        SELECT CASE I
          CASE 0 :   FUNCTION = %PS_SOLID       '  _______
          CASE 1 :   FUNCTION = %PS_DASH        '  -------
          CASE 2 :   FUNCTION = %PS_DOT         '  .......
          CASE 3 :   FUNCTION = %PS_DASHDOT     '  _._._._
          CASE 4 :   FUNCTION = %PS_DASHDOTDOT  '  _.._.._
          CASE ELSE: FUNCTION = %PS_SOLID
        END SELECT
      END FUNCTION
      ' -------------------------------------------------------------------------
      ' The following routines have been heavily inspired by this very fine book:
      ' Ian. O. Angell. Advanced Graphics with the IBM Personal Computer.
      ' -------------------------------------------------------------------------
      SUB Make3Dstructure
          DIM X(16) AS SINGLE, Y(16) AS SINGLE, Z(16) AS SINGLE
          DIM XD(16) AS SINGLE, YD(16) AS SINGLE
          DIM Facet(4, 16) AS LONG, FacetColour(16) AS LONG, FacetCorners(16) AS LONG
          DIM A(1 TO 4,1 TO 4) AS SINGLE, R(1 TO 4,1 TO 4) AS SINGLE, Q(1 TO 4,1 TO 4) AS SINGLE
          DIM B(1 TO 4,1 TO 4) AS SINGLE
          LOCAL M&,I&,NOF&,NOV&
          LOCAL XX AS SINGLE, YY AS SINGLE, ZZ AS SINGLE
      
          ' Make virtual window background.
          hBrush = BrushArray(25)
      
          SelectObject memdc, hBrush
          PatBlt memdc, 0, 0, Rct.nRight, Rct.nBottom, %PATCOPY
      
          NOF& = 16  ' Number of facets
          NOV& = 16  ' Number of vertices ("corners")
      
            ' Read x,y,z coordinates of each vertex ("corner") in the structure
            DATA   -2.138,-2.218,-2.24,  2.138,-2.218,-2.24,  2.138,2.218,-2.24,  -2.138,2.218,-2.24
            DATA   -2.138,-2.218,2.24,   2.138,-2.218,2.24,   2.138,2.218,2.24,   -2.138,2.218,2.24
            DATA   -1.487,-1.766,-1.3,   1.487,-1.766,-1.3,   1.487,1.766,-1.3,   -1.487,1.766,-1.3
            DATA   -1.487,-1.766,1.3,    1.487,-1.766,1.3,    1.487,1.766,1.3,    -1.487,1.766,1.3
      
            FOR I& = 1 TO NOV&
                INCR M&: X(I&)=VAL(READ$(M&))
                INCR M&: Y(I&)=VAL(READ$(M&))
                INCR M&: Z(I&)=VAL(READ$(M&))
            NEXT I&
      
            ' Read sequence of vertices of each facet.
            ' This sequence should be counter-clockwise
            ' when seen from the outside of the structure.
      
            DATA  4, 3, 7, 8,   1, 5, 6, 2,   2, 6, 7, 3,   5, 1, 4, 8
            DATA 11,12,16,15,   9,10,14,13,  10,11,15,14,  13,16,12, 9
            DATA  4,12,11, 3,   9, 1, 2,10,   2, 3,11,10,   1, 9,12, 4
            DATA 16, 8, 7,15,   5,13,14, 6,  15, 7, 6,14,   8,16,13, 5
      
            FOR I& = 1 TO NOF&
                INCR M&: Facet(1,I&)=VAL(READ$(M&))
                INCR M&: Facet(2,I&)=VAL(READ$(M&))
                INCR M&: Facet(3,I&)=VAL(READ$(M&))
                INCR M&: Facet(4,I&)=VAL(READ$(M&))
                FacetCorners(I&) = 4 ' Number of corners in facet
            NEXT I&
      
            ' Read color codes for facets
            DATA 24,16,23,23,18,22,20,20,21,23,22,22,21,23,22,22
      
            FOR I& = 1 TO NOF&
                INCR M&: FacetColour(I&)=VAL(READ$(M&))
            NEXT I&
      
           'move complete object into OBSERVED position.
           MAT R() = IDN
           CALL LookAtStructureFromViewpoint(A(),R(),B())
           'get screen coordinates.
           FOR M& = 1 TO NOV&
               XX = X(M&): YY = Y(M&): ZZ = Z(M&)
               X(M&) = R(1, 1) * XX + R(1, 2) * YY + R(1, 3) * ZZ + R(1, 4)
               Y(M&) = R(2, 1) * XX + R(2, 2) * YY + R(2, 3) * ZZ + R(2, 4)
               Z(M&) = R(3, 1) * XX + R(3, 2) * YY + R(3, 3) * ZZ + R(3, 4)
               XD(M&) = X(M&) * PPD / Z(M&)
               YD(M&) = Y(M&) * PPD / Z(M&)
           NEXT M&
      
           CALL DrawScreenPicture(NOF&,Facet(),XD(),YD(), _
                  FacetCorners(),FacetColour(), _
                  X(), Y(), Z(),PPD)
      END SUB
      ' ------------------------------------------------
      SUB LookAtStructureFromViewpoint(A() AS SINGLE,R() AS SINGLE,B() AS SINGLE)
           LOCAL DX AS SINGLE,DY AS SINGLE,DZ AS SINGLE
           LOCAL TX AS SINGLE,TY AS SINGLE,TZ AS SINGLE
           LOCAL FX AS SINGLE,FY AS SINGLE,FZ AS SINGLE
           LOCAL THETA AS SINGLE, AX AS SINGLE, AY AS SINGLE
           LOCAL AXIS&, DIST AS SINGLE
           LOCAL I&,J&,K&
           LOCAL t AS STRING,t2 AS STRING
           ' Eye position EX, EY, EZ - Global variables
           DX = 0: DY = 0: DZ = 0
           ' Move origin to (DX,DY,DZ).
           LET TX = -DX: LET TY = -DY: TZ = -DZ
           MAT A() = IDN : A(1, 4) = TX: A(2, 4) = TY: A(3, 4) = TZ
           MAT B() = A() * R() : MAT R() = B()
           ' Move eye onto negative z-axis, looking at origin.
           FX = EX - DX: FY = EY - DY: FZ = EZ - DZ
           AX = FX: AY = FY
           CALL ViewingAngle(AX, AY, THETA)
           THETA = -THETA:  AXIS& = 3
           CALL RotateSystem(THETA, AXIS,A())
           MAT B() = A() * R() : MAT R() = B()
           DIST = SQR(FX * FX + FY * FY)
           AX = FZ: AY = DIST
           CALL ViewingAngle(AX, AY, THETA)
           THETA = 3.141593 - THETA: AXIS& = 2
           CALL RotateSystem(THETA, AXIS,A())
           MAT B() = A() * R() : MAT R() = B()
           ' Maintain the vertical.
           TZ = SQR(DIST * DIST + FZ * FZ)
           AX = TZ * FX: AY = -FY * FZ
           CALL ViewingAngle(AX, AY, THETA)
           AXIS& = 3
           CALL RotateSystem(THETA, AXIS, A())
           MAT B() = A() * R() : MAT R() = B()
           ' Move the eye to the origin : space is now in OBSERVED position.
           R(3,4)=TZ
      END SUB
      ' ------------------------------------------------
      SUB RotateSystem(THETA AS SINGLE, AXIS AS LONG,A() AS SINGLE)
            LOCAL AX1&,AX2&,CT AS SINGLE, ST AS SINGLE
            MAT A() = ZER
            AX1& = (AXIS& MOD 3) + 1: AX2& = (AX1& MOD 3) + 1
            CT = COS(THETA): ST = SIN(THETA)
            A(AXIS&, AXIS&) = 1
            A(AX1&, AX1&) = CT: A(AX1&, AX2&) = -ST
            A(AX2&, AX1&) = ST: A(AX2&, AX2&) = CT
      END SUB
      ' ------------------------------------------------
      SUB ViewingAngle(AX AS SINGLE, AY AS SINGLE, THETA AS SINGLE)
             ' THETA is the angle that the line from origin to (AX,AY)
             ' makes with the positive x-axis.
             IF ABS(AX) > .000001 THEN ' Line is not vertical, so it has a finite tangent.
                 THETA = ATN(AY / AX)
                 IF AX < 0 THEN THETA = THETA + 3.141593
             ELSE ' Line is vertical.
                 THETA = 3.141593 / 2
                 IF AY < 0 THEN THETA = THETA + 3.141593
                 IF ABS(AY) < .000001 THEN THETA = 0
             END IF
      END SUB
      ' ------------------------------------------------
      SUB DrawScreenPicture(NOF AS LONG,Facet() AS LONG,XD() AS SINGLE,YD() AS SINGLE, _
                  FacetCorners() AS LONG,FacetColour() AS LONG, _
                  X() AS SINGLE, Y() AS SINGLE, Z() AS SINGLE,PPD AS SINGLE)
            LOCAL HSIZ&,FREE&,NFREE&,NVIS&,I&,I1&,I2&,I3&,FA&,FB&
            LOCAL OVER&,FRONT&,BACK&
            LOCAL X1 AS SINGLE,X2 AS SINGLE,X3 AS SINGLE
            LOCAL Y1 AS SINGLE,Y2 AS SINGLE,Y3 AS SINGLE
            LOCAL DX1 AS SINGLE,DX2 AS SINGLE
            LOCAL DY1 AS SINGLE,DY2 AS SINGLE
            HSIZ& = NOF& * 3  ' Defines size of stack. Must not be too small.
            ' StackArray&(I&) and PointerArray&(I&) are the storage and pointer
            ' locations available for the construction of linked lists.
            ' LIS&(I&) points to a list af indices of facets that lie
            ' in front af facet I&.
            DIM G(NOF&) AS LONG, LIS(NOF&) AS LONG, StackArray(HSIZ&) AS LONG, PointerArray(HSIZ&) AS LONG
            ' FREE& points to a list of free storage locations available
            ' in the StackArray& (and PointerArray&) arrays.
            ' NVIS& is the number of anticlockwise and potentially visible facets.
            FREE& = 1: NVIS& = 0
            ' Initialise the PointerArray& pointers for the linked lists. Initially all the storage in StackArray& is FREE&.
            FOR I& = 1 TO HSIZ&
                PointerArray&(I&) = I& + 1
            NEXT I&
            ' Orientate the projected facets:
            ' G&(I&)=-1 means projected facet I& is clockwise
            ' G&(I&)=0 means it is anticlockwise and potentially visible.
            FOR I& = 1 TO NOF&
                I1& = Facet(1, I&): X1 = XD(I1&): Y1 = YD(I1&)
                I2& = Facet(2, I&): X2 = XD(I2&): Y2 = YD(I2&)
                I3& = Facet(3, I&): X3 = XD(I3&): Y3 = YD(I3&)
                DX1 = X2 - X1: DY1 = Y2 - Y1
                DX2 = X3 - X2: DY2 = Y3 - Y2
                IF DX1 * DY2 - DX2 * DY1 > 0 THEN G&(I&) = 0: NVIS& = NVIS& + 1: LIS&(I&) = 0 ELSE G&(I&) = -1
            NEXT I&
            ' Compare visible facets : FA& with FB&.
            ' G&(FA&) will now hold the number of facets not already
            ' drawn that will lie behind facet FA&.
            FOR FA& = 1 TO NOF& - 1
                IF G&(FA&) <> -1 THEN
                    FOR FB& = FA& + 1 TO NOF&
                        IF G&(FB&) <> -1 THEN
                            CALL CheckOverlapOfFacets(XD(),YD(),FacetCorners(), _
                                 Facet(),FA&,FB&,OVER&,FRONT&,BACK&, _
                                 X(),Y(),Z(),PPD)
                               ' If facets overlap i.e. facet FRONT& in front of facet
                               ' BACK& then increment G&(FRONT&), and add FRONT& to the list
                               ' of facets in front of facet BACK&. Adjust the StackArray&.
                            IF OVER& <> 0 THEN
                                G&(FRONT&) = G&(FRONT&) + 1: NFREE& = PointerArray&(FREE&)
                                StackArray&(FREE&) = FRONT&: PointerArray&(FREE&) = LIS&(BACK&)
                                LIS&(BACK&) = FREE&: FREE& = NFREE&
                            END IF
                        END IF
                    NEXT FB&
                END IF
            NEXT FA&
            ' Sort the network of linked lists of facets to be displayed.
            CALL SortFacetsAccordingToDistance(NOF&,Facet(),FacetCorners(), _
                 FacetColour(),G(),NVIS&, XD(), _
                 YD(),LIS(),StackArray(),PointerArray(),FREE&)
      END SUB
      ' ------------------------------------------------
      SUB CheckOverlapOfFacets(XD() AS SINGLE,YD() AS SINGLE,FacetCorners() AS LONG, _
                  Facet() AS LONG,FA AS LONG,FB AS LONG, _
                  OVER AS LONG, FRONT AS LONG,BACK AS LONG, _
                  X() AS SINGLE, Y() AS SINGLE, Z() AS SINGLE,PPD AS SINGLE)
           LOCAL P1&,P2&,NA&,NB&,NF&,K&,M&,V&,V1&,V2&,V3&,NC&,S1&,S2&
           LOCAL X1 AS SINGLE,X2 AS SINGLE,Y1 AS SINGLE, Y2 AS SINGLE
           LOCAL CC AS SINGLE, CA AS SINGLE,CB AS SINGLE
           LOCAL XI1 AS SINGLE, YI1 AS SINGLE,XI2 AS SINGLE, YI2 AS SINGLE
           LOCAL VAL1 AS SINGLE, VAL2 AS SINGLE, A1 AS SINGLE,A2 AS SINGLE
           LOCAL MU AS SINGLE, UM AS SINGLE, DENOM AS SINGLE
           LOCAL MU1 AS SINGLE, MU2 AS SINGLE
           LOCAL XMID AS SINGLE, YMID AS SINGLE
           LOCAL DX1 AS SINGLE, DX3 AS SINGLE
           LOCAL DY1 AS SINGLE, DY3 AS SINGLE
           LOCAL DZ1 AS SINGLE, DZ3 AS SINGLE
           LOCAL A AS SINGLE, B AS SINGLE,C AS SINGLE,D AS SINGLE
           '
           ' the NA& vertices af facet FA& and the NB& vertices of facet FB&
           ' are obtained from array Facet().
           ' Polygons are stored in anticlockwise orientation.
           ' Check if the view of facets FA& and FB& overlap.
           ' OVER& is set to 1 if they do, and to 0 if they do not.
           P1& = 1: NA& = FacetCorners(FA&): NB& = FacetCorners(FB&): NF& = NA&
           DIM XF(2, NA& + NB&) AS SINGLE, YF(2, NA& + NB&) AS SINGLE
           ' Place projected view of facet FA& in the arrays
           ' XF(1,...) and YF(1,...).
           FOR K& = 1 TO NA&
               V& = Facet(K&, FA&): XF(1, K&) = XD(V&): YF(1, K&) = YD(V&)
           NEXT K&
           ' Use each edge line of facet FB& to slice off part of
           ' the polygon stored in XF,YF.
           ' Line joins point (X1,Y1) to (X2,Y2).
           V1& = Facet(NB&, FB&): X1 = XD(V1&):  Y1 = YD(V1&)
           FOR K& = 1 TO NB&
               V2& = Facet(K&, FB&): X2 = XD(V2&):  Y2 = YD(V2&)
               ' The line is CA.Y+CB.X+CC=0.
               CA = X2 - X1: CB = Y1 - Y2: CC = -X1 * CB - Y1 * CA
               ' Go round the NF& vertices in XF,YF. If positive relative to
               ' the line, then add point to new XF,YF set. If negative
               ' then ignore.
               P2& = 3 - P1&: XI1 = XF(P1&, NF&): YI1 = YF(P1&, NF&)
               VAL1 = CA * YI1 + CB * XI1 + CC: A1 = ABS(VAL1): NC& = 0
               IF A1 < .000001 THEN S1& = 0 ELSE S1& = SGN(VAL1)
               FOR M& = 1 TO NF&
                   XI2 = XF(P1&, M&): YI2 = YF(P1&, M&)
                   VAL2 = CA * YI2 + CB * XI2 + CC: A2 = ABS(VAL2)
                   IF A2 < .000001 THEN S2& = 0 ELSE S2& = SGN(VAL2)
                   IF S1& >= 0 THEN NC& = NC& + 1: XF(P2&, NC&) = XI1: YF(P2&, NC&) = YI1
                   IF S1& <> S2& AND S1& <> 0 AND S2& <> 0 THEN
                       ' If there is an intersection then also add to new XF,YF arrays.
                       MU = A1: UM = A2: DENOM = A1 + A2: NC& = NC& + 1
                       XF(P2&, NC&) = (UM * XI1 + MU * XI2) / DENOM: YF(P2&, NC&) = (UM * YI1 + MU * YI2) / DENOM
                   END IF
                   VAL1 = VAL2: S1& = S2&: A1 = A2: XI1 = XI2: YI1 = YI2
               NEXT M&
               ' If facets do not overlap then OVER&=0.
               IF NC& < 3 THEN OVER& = 0: EXIT SUB
               NF& = NC&: P1& = P2&: X1 = X2: Y1 = Y2
           NEXT K&
           ' Find (XMID,YMID) common to both projected facets.
           XMID = (XF(P1&, 1) + XF(P1&, 2) + XF(P1&, 3)) / 3
           YMID = (YF(P1&, 1) + YF(P1&, 2) + YF(P1&, 3)) / 3
           V1& = Facet(1, FA&): V2& = Facet(2, FA&):  V3& = Facet(3, FA&)
           GOSUB Distance : MU1 = MU2 ' Get distance MU1
           ' MU1 is the distance of the eye from that point
           ' on facet FA& which is projected into (XMID,YMID).
           V1& = Facet(1, FB&): V2& = Facet(2, FB&): V3& = Facet(3, FB&)
           GOSUB Distance             ' Get distance MU2
           ' MU2 is the distance of the eye from that point
           ' on facet FB which is projected into (XMID,YMID).
           '
           ' Ff MU1>MU2 then facet FB& is closer to the eye, that is
           ' facet FB& is in front af facet FA&. Similarly if MU1<MU2.
           OVER& = 1
           IF MU1 > MU2 THEN FRONT& = FB&: BACK& = FA& ELSE FRONT& = FA&: BACK& = FB&
           EXIT SUB
           '
           Distance:
               DX1 = X(V1&) - X(V2&): DX3 = X(V3&) - X(V2&)
               DY1 = Y(V1&) - Y(V2&): DY3 = Y(V3&) - Y(V2&)
               DZ1 = Z(V1&) - Z(V2&): DZ3 = Z(V3&) - Z(V2&)
               A = DY1 * DZ3 - DY3 * DZ1: B = DZ1 * DX3 - DZ3 * DX1: C = DX1 * DY3 - DX3 * DY1
               D = A * X(V1&) + B * Y(V1&) + C * Z(V1&)
               MU2 = D / (A * XMID + B * YMID + C * PPD)
           RETURN
      END SUB
      ' ------------------------------------------------
      SUB SortFacetsAccordingToDistance(NOF AS LONG,Facet() AS LONG,FacetCorners() AS LONG, _
                  FacetColour() AS LONG,G() AS LONG,NVIS AS LONG, XD() AS SINGLE, _
                  YD() AS SINGLE,LIS() AS LONG,StackArray() AS LONG,PointerArray() AS LONG,FREE AS LONG)
             LOCAL StackPosition&,F&,ValueIn&,ValueOut&,NC&,COLFAC&,I&,V&,PT&,F2&
             StackPosition& = 0
             DIM XC(10) AS SINGLE, YC(10) AS SINGLE
             ' Create a stack. Push on it all facets F& that have
             ' no facets behind them i.e. G&(F&)=0
             FOR F& = 1 TO NOF&
                 IF G&(F&) = 0 THEN ValueIn& = F&: CALL PushValueOntoStack(ValueIn,FREE,StackPosition,PointerArray(),StackArray())
             NEXT F&
             ' Find an order for drawing all the visible facets
             ' so that hidden sections are obliterated. Draw
             ' facets that have no undrawn facets behind them.
             FOR F& = 1 TO NVIS&
                 ' Pop a facet which has no undrawn facet behind it.
                 CALL PopValueFromTopOfStack(ValueOut,FREE,StackPosition,PointerArray(),StackArray())
                 ' If no facet is available, there is an error in the data.
                 IF ValueOut& = 0 THEN MSGBOX "Error in the data - network has a cycle"': STOP
                 ' Draw the facet.
                 NC& = FacetCorners(ValueOut&): COLFAC& = FacetColour(ValueOut&)
                 FOR I& = 1 TO NC&
                     V& = Facet(I&, ValueOut&): XC(I&) = XD(V&): YC(I&) = YD(V&)
                 NEXT I&
                 CALL DrawThisFacet(NC&,XC(),YC(),COLFAC&)
                 ' After the facet is drawn, adjust the values of array G&.
                 ' Use the list LIS& to find facets in front of last facet drawn.
                 ' Now G&(F&) holds the number of undrawn facets behind facet F&
                 PT& = LIS&(ValueOut&)
                 DO UNTIL PT& = 0
                     F2& = StackArray&(PT&)
                     G&(F2&) = G&(F2&) - 1
                     ' If facet F2& has no undrawn facet behind it, push it on stack
                     IF G&(F2&) = 0 THEN ValueIn& = F2&: CALL PushValueOntoStack(ValueIn,FREE,StackPosition,PointerArray(),StackArray())
                     PT& = PointerArray&(PT&)
                 LOOP
             NEXT F&
      END SUB
      ' ------------------------------------------------
      SUB DrawThisFacet(NC AS LONG,XC() AS SINGLE,YC() AS SINGLE,COLFAC AS LONG)
          DIM pxy(0 TO 10) AS POINTAPI
          LOCAL Res&
          LOCAL V&
          ' Fill points array with data adapted for graphics window dimensions
          FOR V& = 1 TO NC&
              pxy(V&-1).x=XC(V&)*Rct.nRight*0.25 + Rct.nRight * 0.5
              pxy(V&-1).y=Rct.nBottom-(YC(V&)*Rct.nBottom*0.3+Rct.nBottom*0.5)
          NEXT V&
          pxy(NC&).x=XC(1)*Rct.nRight*0.25 + Rct.nRight * 0.5
          pxy(NC&).y=Rct.nBottom-(YC(1)*Rct.nBottom*0.3+Rct.nBottom * 0.5)
          '
          hBrush = SelectObject(memdc,BrushArray(COLFAC&))
          ' Draw polygon in selected color
          Res&=POLYGON(BYVAL memdc,pxy(0),BYVAL NC&)
          ' hPen = SelectObject(memdc, CreatePen(PenStyle(0), 0, gColor(0)))
          ' Draw outline of polygon in black. Uses default pen color and style: black and solid
          Res&=POLYLINE(BYVAL memdc,pxy(0), BYVAL (NC&+1))
      END SUB
      ' ------------------------------------------------
      SUB PushValueOntoStack(ValueIn AS LONG,FREE AS LONG,StackPosition AS LONG,PointerArray() AS LONG,StackArray() AS LONG) '&'8000  'push ' s 226
          LOCAL NF&
          NF& = FREE&                         ' Free position in stack.
          StackArray&(NF&) = ValueIn&         ' Put value onto stack in free position.
          FREE& = PointerArray&(FREE&)        ' New free position in stack.
          PointerArray&(NF&) = StackPosition& ' Update pointer array
          StackPosition& = NF&                ' New top position in stack
      END SUB
      ' ------------------------------------------------
      SUB PopValueFromTopOfStack(ValueOut AS LONG,FREE AS LONG,StackPosition AS LONG,PointerArray() AS LONG,StackArray() AS LONG) '8100  'pop ' s 226
          LOCAL NF&
          NF& = StackPosition&                ' Position of top item in stack.
          ValueOut& = StackArray&(NF&)        ' Get value out from this position.
          StackPosition& = PointerArray&(NF&) ' New top position in stack.
          PointerArray&(NF&) = FREE&          ' Update pointer array.
          FREE& = NF&                         ' New free position in stack.
      END SUB
      ' ------------------------------------------------
      Attached Files
      Last edited by Erik Christensen; 16 Jul 2013, 08:05 AM.

      Comment


      • #4
        The update crashed in Win7 compiled fine in PBwin9
        Both app compile fin in PBWin but crashed both in Win7 and XP
        Last edited by Gary Beene; 18 Jan 2015, 11:53 AM.

        Comment


        • #5
          Brusharray structure does seem to be too happy - runs OK with the changes below:-


          Code:
          SUB Make3Dstructure
              DIM X(16) AS SINGLE, Y(16) AS SINGLE, Z(16) AS SINGLE
              DIM XD(16) AS SINGLE, YD(16) AS SINGLE
              DIM Facet(4, 16) AS LONG, FacetColour(16) AS LONG, FacetCorners(16) AS LONG
              DIM A(1 TO 4,1 TO 4) AS SINGLE, R(1 TO 4,1 TO 4) AS SINGLE, Q(1 TO 4,1 TO 4) AS SINGLE
              DIM B(1 TO 4,1 TO 4) AS SINGLE
              LOCAL M&,I&,NOF&,NOV&
              LOCAL XX AS SINGLE, YY AS SINGLE, ZZ AS SINGLE
              LOCAL hBrush1 AS LONG
          
              ' Make virtual window background.
              hBrush1 = %BLUE 'BrushArray(25) 'line 473
              SelectObject memdc, hBrush1
              PatBlt memdc, 0, 0, Rct.nRight, Rct.nBottom, %PATCOPY
          
              NOF& = 16  ' Number of facets
              NOV& = 16  ' Number of vertices ("corners")  
          
          etc......................................
          Iain Johnstone
          “None but those who have experienced them can conceive of the enticements of science” - Mary Shelley

          Comment

          Working...
          X