Announcement

**Erik Christensen** · 7 Apr 2002, 03:17 PM

' 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 ----- [email protected]
'
' 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 ---- [email protected]"
    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       [email protected]"+$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).]

**Erik Christensen** · 16 Jul 2013, 06:15 AM

' 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

**Stephane Fonteyne** · 18 Jan 2015, 09:33 AM

The update crashed in Win7 compiled fine in PBwin9
Both app compile fin in PBWin but crashed both in Win7 and XP

**Iain Johnstone** · 18 Jan 2015, 02:06 PM

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

Announcement

Forum Guidelines

3D-Graphics Demonstration Program

3D-Graphics Demonstration Program

Comment

Comment

Comment

Comment