|
|
||
| Home | SwiftForth Archive | SwiftX Archive | |
Hi Dennis
> Ok, no answer implies an answer to my next question, but I'll ask it
> anyway. Has anyone implemented external library calls to functions
> that take floating point parameters? I note that the SwiftForth
> support does not implement them, but I'm kind of hoping someone else
> has looked at the issue and might have some advice, at least.
There are some OpenGL demos out there that do what it sound like you are
asking for. The one below is from the SwiftForth message archive and
starts off with a few routines to pass floats to OpenGL. I was mucking
around with calls to an image processing library Freeimage.dll (
http://freeimage.sourceforge.net/sourcecode.html ) recently and used the
same mechnism to pass float parameters with some success.
Hope this helps, Roland
\ =====================================================================
\ 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
LIBRARY glu32.dll
LIBRARY OpenGL32.dll
DECIMAL
\ ---------------------------------------------------------------------
\ Tools to pass float/double to 'C' API
\ ---------------------------------------------------------------------
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.02e 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 10 0 SetTimer DROP 0 ; \ Changes rate of OGL
object spin
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 ;
\ ---------------------------------------------------------------------
Test
----------------------------------------------------------------------
sftalk_at_forth.com The SwiftForth programming discussion email list
To unsubscribe, send subject "unsubscribe" to sftalk-request_at_forth.com
For list command help, send subject "help" to sftalk-request_at_forth.com
Message archives are located at http://www.forth.com/archive/sftalk
----------------------------------------------------------------------
This list is a forum for SwiftForth users. For product support and
bug reports, please send email to support_at_forth.com
----------------------------------------------------------------------
Received on Tue Jan 09 2007 - 08:57:49 PST
This archive was generated by hypermail 2.2.0 : Tue Dec 02 2008 - 03:04:41 PST