This is a extended OpenGL test.

Very usefull to check OpenGL parameters.

Charles

\ =====================================================================
\ GLLIGHT.F - V1.0 - 26 sept 1999
\ SwiftForth OpenGL test - based on previous GLMINI.F test
\ NB: 16 bit true color mode = minimum necessary
\ =====================================================================

REQUIRES FPMATH \ any model

LIBRARY glu32.dll \ Win95 users: see "www.opengl.org"
LIBRARY OpenGL32.dll \ "

DECIMAL

\ ---------------------------------------------------------------------
\ OpenGL used constants - to remove if you have updated WINCON.DLL
\ ---------------------------------------------------------------------

$1602 CONSTANT GL_AMBIENT_AND_DIFFUSE
$4000 CONSTANT GL_COLOR_BUFFER_BIT
$0B57 CONSTANT GL_COLOR_MATERIAL
$1301 CONSTANT GL_COMPILE_AND_EXECUTE
$0100 CONSTANT GL_DEPTH_BUFFER_BIT
$0B71 CONSTANT GL_DEPTH_TEST
$0408 CONSTANT GL_FRONT_AND_BACK
$4000 CONSTANT GL_LIGHT0
$0B52 CONSTANT GL_LIGHT_MODEL_TWO_SIDE
$0B50 CONSTANT GL_LIGHTING
$1700 CONSTANT GL_MODELVIEW
$0BA1 CONSTANT GL_NORMALIZE
$1203 CONSTANT GL_POSITION
$1601 CONSTANT GL_SHININESS
$1D01 CONSTANT GL_SMOOTH
$1202 CONSTANT GL_SPECULAR
$0001 CONSTANT GL_TRUE

\ ---------------------------------------------------------------------
\ Tools to pass float/double to 'C' API
\ ---------------------------------------------------------------------

{ replaced by faster CODE version
    | FVARIABLE (fvar)
    |
    | : 4sfparms ( f: x y z t -- ) ( s: -- x y z t )
    | (fvar) DUP SF! @ >R
    | (fvar) DUP SF! @
    | (fvar) DUP SF! @
    | (fvar) DUP SF! @ \ s: z y x
    | SWAP ROT R> ;
    |
    | : 1dfparms ( f: x -- ) ( s: -- xl xh )
    | (fvar) DUP F! 2@ SWAP ;
    V }

CODE 4sfparms ( f: x y z t -- ) ( s: -- x y z t )
   4 >fs \ make sure data on hardware stack
   16 # EBP SUB \ room for 4 integers and tos
   12 [EBP] DWORD FSTP \ convert t
    0 [EBP] DWORD FSTP \ convert z
    4 [EBP] DWORD FSTP \ convert y
    8 [EBP] DWORD FSTP \ convert x
   12 [EBP] EBX XCHG \ swap t and old tos
   RET END-CODE

CODE 1dfparms ( f: x -- ) ( s: -- xl xh )
>f \ make sure data on hardware stack
   8 # EBP SUB \ make room for double
   0 [EBP] QWORD FSTP \ convert
   4 [EBP] EBX XCHG \ swap xh and old tos
   RET END-CODE

\ also...
CODE 3sfparms ( f: x y z -- ) ( s: -- x y z )
   3 >fs \ make sure data on hardware stack
   12 # EBP SUB \ room for 3 integers and tos
    8 [EBP] DWORD FSTP \ convert z
    0 [EBP] DWORD FSTP \ convert y
    4 [EBP] DWORD FSTP \ convert x
    8 [EBP] EBX XCHG \ swap z and old tos
   RET END-CODE

\ also...
CODE 1sfparms ( f: x -- ) ( s: -- x )
   1 >fs \ make sure data on hardware stack
    4 # EBP SUB \ room for 1 integers and tos
    0 [EBP] DWORD FSTP \ convert x
    0 [EBP] EBX XCHG \ swap x and old tos
   RET END-CODE

\ ---------------------------------------------------------------------
\ Minimalist struct package
\ ---------------------------------------------------------------------

: Field ( ofs n "name" -- n+ofs ) CREATE OVER , + DOES> @ + ;
: End-Struct ( n "name" -- ) CONSTANT ;
0 End-Struct Struct ( -- )

: HVAR CELL 2/ Field ;
: CVAR 1 CHARS Field ;
: VAR CELL Field ;

\ ---------------------------------------------------------------------
\ PixelFormat structure, SetupPixelFormat
\ ---------------------------------------------------------------------

Struct
    HVAR pix.nSize
    HVAR pix.nVersion
    VAR pix.dwFlags
    CVAR pix.iPixelType
    CVAR pix.cColorBits
    CVAR pix.cRedBits
    CVAR pix.cRedShift
    CVAR pix.cGreenBits
    CVAR pix.cGreenShift
    CVAR pix.cBlueBits
    CVAR pix.cBlueShift
    CVAR pix.cAlphaBits
    CVAR pix.cAlphaShift
    CVAR pix.cAccumBits
    CVAR pix.cAccumRedBits
    CVAR pix.cAccumGreenBits
    CVAR pix.cAccumBlueBits
    CVAR pix.cAccumAlphaBits
    CVAR pix.cDepthBits
    CVAR pix.cStencilBits
    CVAR pix.cAuxBuffers
    CVAR pix.iLayerType
    CVAR pix.bReserved
    VAR pix.dwLayerMask
    VAR pix.dwVisibleMask
    VAR pix.dwDamageMask
End-Struct PIXELFORMATDESCRIPTOR

PIXELFORMATDESCRIPTOR BUFFER: pf

Function: ChoosePixelFormat ( hdc ppfd -- int )
Function: SetPixelFormat ( hdc iPix ppfd -- flag )

: SetupPixelFormat ( hdc -- )
>R pf PIXELFORMATDESCRIPTOR ERASE
    PIXELFORMATDESCRIPTOR pf pix.nSize H! \ struct size
    1 pf pix.nVersion H!
    PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL OR PFD_DOUBLEBUFFER OR pf
pix.dwFlags !
    PFD_TYPE_RGBA pf pix.iPixelType C!
    24 pf pix.cColorBits C!
    32 pf pix.cDepthBits C!
    R@ pf ChoosePixelFormat DUP 0= ABORT" cannot ChoosePixelFormat"
    R> SWAP pf SetPixelFormat 0= ABORT" cannot SetPixelFormat" ;

\ ---------------------------------------------------------------------
\ Drawing tools
\ ---------------------------------------------------------------------

0 VALUE qobj

Function: gluNewQuadric ( -- qobj )
Function: gluDeleteQuadric ( qobj -- )

5 IMPORT: gluSphere ( qobj 2radius slices stacks -- 0 )

: gluSphere ( qobj slices stacks -- ) ( f: radius -- )
    2>R 1dfparms 2R> gluSphere DROP ;

9 IMPORT: gluCylinder ( qobj 2baseRad 2topRad 2height slices stacks -- 0
)

: gluCylinder ( qobj slices stacks -- ) ( f: height topRad
baseRad -- )
    2>R 1dfparms 1dfparms 1dfparms 2R> gluCylinder DROP ;

Function: glColor3fv ( prgb -- )

\ ---------------------------------------------------------------------
\ Display list for subsequent fast execution.
\ ---------------------------------------------------------------------

Function: glNewList ( list mode -- )
Function: glEndList ( -- )
Function: glCallList ( list -- )
Function: glDeleteLists ( list range -- )

\ ---------------------------------------------------------------------
\ Matrix transformations
\ ---------------------------------------------------------------------

Function: glMatrixMode ( mode -- )
Function: glLoadIdentity ( -- )
Function: glPushMatrix ( -- )
Function: glPopMatrix ( -- )

Function: glRotatef ( deg x y z -- )

: glRotatef ( f: deg x y z -- )
    4sfparms glRotatef ;

Function: glTranslatef ( x y z -- )

: glTranslatef ( f: x y z -- )
    3sfparms glTranslatef ;

\ ---------------------------------------------------------------------
\ 3D Single floats vectors - also can hold RGB triple sfloats values
\ ---------------------------------------------------------------------

: SFLOAT- ( addr -- addr- )
    [DEFINED] CELL- [ 1 SFLOATS CELL = AND ]
    [IF] CELL- [ELSE] 1 SFLOATS - [THEN] ;

: SFVECTOR3 ( f: -- ) ( -- )
    CREATE 3 0 DO 0e SF, LOOP DOES> ; ( -- caddr )

: SFX ( addr -- xaddr ) NOOP ; IMMEDIATE
: SFY ( addr -- yaddr ) SFLOAT+ ;
: SFZ ( addr -- zaddr ) 2 SFLOATS + ;

: SF3! ( addr -- ) ( f: x y z -- )
    SFZ DUP SF! SFLOAT- DUP SF! SFLOAT- SF! ;

: SF3@ ( addr -- ) ( f: -- x y z )
    DUP SF@ SFLOAT+ DUP SF@ SFLOAT+ SF@ ;

\ ---------------------------------------------------------------------
\ 4D Single floats vectors
\ ---------------------------------------------------------------------

: SFVECTOR4 ( f: -- ) ( -- )
    CREATE 4 0 DO 0e SF, LOOP DOES> ; ( -- caddr )

: SFT ( addr -- taddr ) 3 SFLOATS + ;

: SF4! ( addr -- ) ( f: x y z t -- )
    SFT DUP SF! SFLOAT- DUP SF! SFLOAT- DUP SF! SFLOAT- SF! ;

\ ---------------------------------------------------------------------
\ Draw Scene one time, then deleguate to glCallList (faster)
\ ---------------------------------------------------------------------

0 VALUE LIST-COMPILED

: DeleteList ( -- )
    LIST-COMPILED 1 glDeleteLists
    0 TO LIST-COMPILED ;

\ Object metric

0.05e FCONSTANT cylR
0.10e FCONSTANT boulR
0.80e FCONSTANT cylH
cylH FNEGATE FCONSTANT -cylH
cylH F2/ FCONSTANT cylH/2
cylH/2 FNEGATE FCONSTANT -cylH/2

\ Object colors

SFVECTOR3 ^RGB1 0.1e 0.8e 0.3e ^RGB1 SF3!
SFVECTOR3 ^RGB2 0.2e 0.9e 0.9e ^RGB2 SF3!

\ Object elements

: DrawPipe ( -- )
    ^RGB1 glColor3fv
    qobj 8 DUP cylH cylR FDUP gluCylinder ;

: DrawSphere ( -- )
    ^RGB2 glColor3fv
    qobj 16 DUP boulR gluSphere ;

: DrawPipeSphere ( -- )
    DrawPipe
    DrawSphere
    glPushMatrix
    0e 0e cylH glTranslatef
    DrawSphere
    glPopMatrix ;

\ Object

: DrawScene ( -- )
    LIST-COMPILED 0=
    IF \ executed one time,
        1 TO LIST-COMPILED
        gluNewQuadric TO qobj
        LIST-COMPILED GL_COMPILE_AND_EXECUTE glNewList
        glPushMatrix
        \ ----- 4 x tube-boules -----
        -cylH/2 -cylH/2 -cylH/2 glTranslatef DrawPipeSphere
        cylH 0e 0e glTranslatef DrawPipeSphere
        0e cylH 0e glTranslatef DrawPipeSphere
        -cylH 0e 0e glTranslatef DrawPipeSphere
        \ ----- 4 x tubes -----
        glPopMatrix glPushMatrix
        -90e 1e 0e 0e glRotatef
        -cylH/2 -cylH/2 -cylH/2 glTranslatef DrawPipe
        cylH 0e 0e glTranslatef DrawPipe
        0e cylH 0e glTranslatef DrawPipe
        -cylH 0e 0e glTranslatef DrawPipe
        \ ----- 4 x tubes -----
        glPopMatrix glPushMatrix
        90e 0e 1e 0e glRotatef
        -cylH/2 -cylH/2 -cylH/2 glTranslatef DrawPipe
        cylH 0e 0e glTranslatef DrawPipe
        0e cylH 0e glTranslatef DrawPipe
        -cylH 0e 0e glTranslatef DrawPipe
        glPopMatrix
        glEndList
    ELSE
        LIST-COMPILED glCallList
    THEN ;

\ ---------------------------------------------------------------------
\ Clear, redraw in back-buffer, SwapBuffers=display
\ ---------------------------------------------------------------------

Function: glClear ( mask -- )
Function: SwapBuffers ( hdc -- bool )
Function: glLightfv ( light pname params -- )

\ Light position
SFVECTOR4 LightPos -1e 1e 10e 1e LightPos SF4!

: Expose ( -- )
    GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT OR glClear

    \ -- Light position immuable --
    GL_MODELVIEW glMatrixMode
    glPushMatrix glLoadIdentity
    GL_LIGHT0 GL_POSITION LightPos glLightfv

    \ -- incremental rotate object --
    glPopMatrix
    2e 1e 1e 1e glRotatef DrawScene

    \ -- display --
    HWND GetDC SwapBuffers DROP ;

\ -----------------------------------------------------------------------
\ Setup OpenGL engine
\ -----------------------------------------------------------------------

Function: glColorMaterial ( face mode -- )
Function: glDisable ( caps -- )
Function: glEnable ( caps -- )
Function: glLightModeli ( pname param -- )
Function: glMaterialfv ( face name param -- )
Function: glShadeModel ( mode -- )
Function: glViewport ( ix iy icx icy -- )
Function: wglCreateContext ( hdc -- hrc )
Function: wglDeleteContext ( hrc -- )
Function: wglMakeCurrent ( hdc hglrc -- ok )

SFVECTOR4 pSpecu 1e FDUP FDUP 1e pSpecu SF4!
SFVARIABLE pShininess 120e pShininess SF! \ metal ?

: SetupOpenGLState ( -- )
    GL_FRONT_AND_BACK GL_SHININESS pShininess glMaterialfv
    GL_FRONT_AND_BACK GL_SPECULAR pSpecu glMaterialfv
    GL_COLOR_MATERIAL glEnable
    GL_LIGHTING glEnable
    GL_LIGHT0 glEnable
    GL_DEPTH_TEST glEnable
    GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial
    GL_LIGHT_MODEL_TWO_SIDE GL_TRUE glLightModeli
    GL_SMOOTH glShadeModel
    \ -- camera parameters --
    GL_PROJECTION glMatrixMode
    -45e -1e -1e 1e glRotatef
    \ -- initial clear before first display --
    GL_COLOR_BUFFER_BIT glClear ;

\ -----------------------------------------------------------------------
\ GlWindowProc - process all wnd messages
\ -----------------------------------------------------------------------

0 VALUE HRC \ OpenGL rendering context - only one in this test
50 CONSTANT TIMID \ animation timer identifier

: SwitchDefault ( msg -- res )
    HWND SWAP WPARAM LPARAM DefWindowProc ;

[SWITCH SwitchMsg SwitchDefault ( msg -- res )

    WM_TIMER RUN:
        0 WPARAM TIMID <> ?EXIT \ not my timer event
        Expose ;

    WM_PAINT RUN: \ just redraw back-buffer
        HWND GetDC SwapBuffers DROP
        WM_PAINT SwitchDefault ;

    WM_SIZE RUN:
        0 0 LPARAM LOHI glViewport 0 ;

    WM_CREATE RUN: \ NB: ReleaseDC not necessary: CS_OWNDC
        HWND GetDC DUP SetupPixelFormat
        DUP wglCreateContext TO HRC
        HRC wglMakeCurrent DROP
        SetupOpenGLState
        HWND TIMID 60 0 SetTimer DROP 0 ;

    WM_DESTROY RUN:
        HWND TIMID KillTimer DROP
        0 0 wglMakeCurrent DROP
        DeleteList
        qobj gluDeleteQuadric
        HRC wglDeleteContext 0 TO HRC 0 ;
SWITCH]

:NONAME ( -- res ) \ GlWindowProc
    [DEFINED] NUMERICS [IF] #NS FSTACK [THEN]
    MSG SwitchMsg ; 4 CB: GlWindowProc

\ ---------------------------------------------------------------------
\ Register class, create the window
\ ---------------------------------------------------------------------

CREATE szGlClass ,Z" GLDemoWnd" ( -- szClassName )

: RegisterGlClass ( -- res )
    CS_HREDRAW CS_VREDRAW OR CS_OWNDC OR
    GlWindowProc
    0
    8
    HINST
    HINST 101 LoadIcon
    0 IDC_ARROW LoadCursor
    0 \ WM_ERASEBKGND unnecessary...
    0
    szGlClass
    DefineClass ;

: TEST ( -- )
    HRC ABORT" - one occurence only !"
    RegisterGlClass DROP
    0 \ extended window style
    szGlClass \ address of registered class name
    Z" SwiftForth OpenGL test" \ address of window name
    WS_OVERLAPPEDWINDOW \ window style
    WS_VISIBLE OR \ "
    CW_USEDEFAULT DUP \ window position...
    300 310 \ ...and size
    0 \ handle of parent or owner window
    0 \ handle of menu or child-window identifier
    HINST \ handle of application instance
    0 \ address of window-creation data
    CreateWindowEx DROP ;

\ ---------------------------------------------------------------------
\ :PRUNE - will close all instances of the class, then unregister it.
\ ---------------------------------------------------------------------

:PRUNE ?PRUNE -EXIT
   BEGIN
      szGlClass 0 FindWindow ?DUP WHILE
      WM_CLOSE 0 0 SendMessage DROP
   REPEAT
   szGlClass HINST UnregisterClass DROP ;

\ ---------------------------------------------------------------------

CR .( type TEST ) CR

\\ EOF

.
Received on Sun Sep 26 1999 - 12:37:15 PDT