Commit dfb01f06 authored by bp's avatar bp

checkin bigforth


git-svn-id: https://forth-ev.de/repos/bigforth@205 3b8d8251-53f3-0310-8f3b-fd1cb8370982
parent 598825e9
\ 3D turtle graphics 27dec98py
memory also dos also
\needs float import float
\needs glconst | import glconst
\needs xconst | import xconst
float also glconst also x11 also opengl also
[IFDEF] win32
:noname ['] noop noop-act 1 1 1 1 glcanvas new glcanvas with
screen self dpy! render dispose endwith drop ;
IS dummy-canvas
[ELSE]
\ | : glarrays ; ." With gl arrays" cr
\ | : debug-points ; ." With debug points" cr
[THEN]
\ r,phi extraction 31dec98py
[IFUNDEF] r,phi>xy
: r,phi>xy ( r phi -- x y )
fsincos frot funder f* f-rot f* ;
[THEN]
[IFUNDEF] 9*
Code 9* AX AX *8 I) AX lea Next end-code macro
\ : 9* 9 * ;
[THEN]
[IFUNDEF] 3*
: 3* dup 2* + ; macro
[THEN]
\ doesn't work for -1
: >2** ( a -- n ) 1 BEGIN 2dup u> WHILE 2* REPEAT nip ;
[IFUNDEF] Code
: inner-get ( addr -- sf ) 3 swap dup sf@ sfloat+
[ 3 sfloats ] Literal bounds
DO dup fpick I sf@ f* f+ 1-
[ 1 sfloats ] Literal +LOOP drop f>fs ;
: 2linear ( addr -- sf ) dup sf@ f* sfloat+ sf@ f+ f>fs ;
: !point ( p z y x addr -- )
!+ !+ !+ !+
[ 2 cells ] Literal + [ 3 cells ] Literal erase ;
: !normal ( z y x addr -- )
[ 6 cells ] Literal + !+ !+ ! ;
: .x sf@ ; macro
: .y cell+ sf@ ; macro
: .z 8+ sf@ ; macro
: .nx dup $14 + sf@ ; macro
: .ny dup $18 + sf@ ; macro
: .nz dup $1C + sf@ ; macro
: .nxsf! dup $14 + sf! ; macro
: .nysf! dup $18 + sf! ; macro
: .nzsf! dup $1C + sf! ; macro
: left-over ( vl v vr -- x1 y1 z1 x2 y2 z2 )
{ vl v vr |
vl .x v .x f- vl .y v .y f- vl .z v .z f-
vr .x v .x f- vr .y v .y f- vr .z v .z f- } ;
: cross* ( x1 y1 z1 x2 y2 z2 -- x3 y3 z3 )
{ f: x1 f: y1 f: z1 f: x2 f: y2 f: z2 |
y1 z2 f* z1 y2 f* f- ( x )
z1 x2 f* x1 z2 f* f- ( y )
x1 y2 f* y1 x2 f* f- ( z ) } ;
: get-normal ( vl v vr -- fx fy fz )
left-over cross* ;
: negate3 ( fx fy fz -- -fx -fy -fz )
fnegate frot fnegate frot fnegate frot ;
[ELSE]
Code inner-get ( fx fy fz addr -- sf )
.fs AX ) fld
.fs 1 sfloats AX D) fld 4 ST fmul 1 STP fadd
.fs 2 sfloats AX D) fld 3 ST fmul 1 STP fadd
.fs 3 sfloats AX D) fld 2 ST fmul 1 STP fadd
.fs -4 SP D) fstp -4 SP D) AX mov
Next end-code macro
Code 2linear ( f addr -- sf )
.fs AX ) fmul .fs 1 sfloats AX D) fadd
.fs -4 SP D) fstp -4 SP D) AX mov
Next end-code macro
Code !point ( p z y x addr -- ) DX DX xor
AX ) pop 1 cells AX D) pop 2 cells AX D) pop
3 cells AX D) pop
DX 6 cells AX D) mov
DX 7 cells AX D) mov
DX 8 cells AX D) mov
AX pop Next end-code macro
Code !normal ( fx fy fz addr -- )
6 cells AX D) pop
7 cells AX D) pop
8 cells AX D) pop
AX pop Next end-code macro
Code .nx ( addr -- addr f ) .fs 5 sfloats AX D) fld
Next end-code macro 0 0 T&P
Code .ny ( addr -- addr f ) .fs 6 sfloats AX D) fld
Next end-code macro 0 0 T&P
Code .nz ( addr -- addr f ) .fs 7 sfloats AX D) fld
Next end-code macro 0 0 T&P
Code .nxsf! ( f addr -- addr ) .fs 5 sfloats AX D) fstp
Next end-code macro 0 0 T&P
Code .nysf! ( f addr -- addr ) .fs 6 sfloats AX D) fstp
Next end-code macro 0 0 T&P
Code .nzsf! ( f addr -- addr ) .fs 7 sfloats AX D) fstp
Next end-code macro 0 0 T&P
Code left-over ( vl v vr -- ) CX pop DX pop
.fs DX ) fld .fs CX ) fsubr
.fs 1 sfloats DX D) fld .fs 1 sfloats CX D) fsubr
.fs 2 sfloats DX D) fld .fs 2 sfloats CX D) fsubr
.fs AX ) fld .fs CX ) fsubr
.fs 1 sfloats AX D) fld .fs 1 sfloats CX D) fsubr
.fs 2 sfloats AX D) fld .fs 2 sfloats CX D) fsubr
AX pop Next end-code
Code cross* ( x1 y1 z1 x2 y2 z2 -- )
4 ST fld 1 ST fmul 4 ST fld 3 ST fmul 1 STP fsubr
.fs -1 sfloats SP D) fstp
3 ST fld 3 ST fmul 6 ST fld 2 ST fmul 1 STP fsubr
.fs -2 sfloats SP D) fstp
5 ST fld 2 ST fmul 5 ST fld 4 ST fmul 1 STP fsubr
.fs -3 sfloats SP D) fstp
0 ST fstp 0 ST fstp 0 ST fstp
0 ST fstp 0 ST fstp 0 ST fstp
.fs -1 sfloats SP D) fld
.fs -2 sfloats SP D) fld
.fs -3 sfloats SP D) fld Next end-code
: get-normal ( vl v vr -- fx fy fz )
left-over cross* ;
Code negate3 ( fx fy fz -- -fx -fy -fz )
fchs 1 ST fxch fchs 2 ST fxch fchs
2 ST fxch 1 ST fxch Next end-code macro
[THEN]
[IFDEF] libGLU
: >c ( xt -- ) dup 2- w@ + &11 - cfa@ ;
: >c' ( xt -- offset addr ) dup 2- w@ + &10 - dup 4+ ;
\ define a few C-callbacks
Code glVertexTexCoord3fv ( c:addr -- ) R:
4 SP D) AX mov $C # AX add AX push
' glTexCoord2fv >c' A# AX mov A#) AX add AX call AX pop
4 SP D) AX mov AX push
' glVertex3fv >c' A# AX mov A#) AX add AX call AX pop
ret end-code
Code glVertexNormalTexCoord3fv ( c:addr -- ) R:
4 SP D) AX mov $C # AX add AX push
' glTexCoord2fv >c' A# AX mov A#) AX add AX call AX pop
4 SP D) AX mov $14 # AX add AX push
' glNormal3fv >c' A# AX mov A#) AX add AX call AX pop
4 SP D) AX mov AX push
' glVertex3fv >c' A# AX mov A#) AX add AX call AX pop
ret end-code
[THEN]
!1 f>fs Constant #1
pi f2* FConstant 2pi
2pi 1/f FConstant 1/2pi
\ : .matrix ( addr -- )
\ &12 sfloats bounds
\ DO cr I 4 sfloats bounds
\ DO I sf@ !2 f+ !2 f- f. 1 sfloats +LOOP
\ 4 sfloats +LOOP ;
Create .white #1 , #1 , #1 , #1 ,
[IFDEF] debug-points
Variable maxpoints
Variable #points
$7FFFFFFF maxpoints !
: ?maxpoints ( addr -- )
#points @ maxpoints @ > IF drop rdrop THEN ;
: points+ 1 #points +! ;
[ELSE]
' noop alias ?maxpoints immediate
' noop alias points+ immediate
[THEN]
\ class declaration 03jan99py
true Value do-mipmap
debugging class 3d-turtle
public:
0 sfloats var trans
1 sfloats var trans-0,0
1 sfloats var trans-1,0
1 sfloats var trans-2,0
1 sfloats var trans-3,0
1 sfloats var trans-0,1
1 sfloats var trans-1,1
1 sfloats var trans-2,1
1 sfloats var trans-3,1
1 sfloats var trans-0,2
1 sfloats var trans-1,2
1 sfloats var trans-2,2
1 sfloats var trans-3,2
1 sfloats var z-off
1 sfloats var x-text
1 sfloats var x-toff
1 sfloats var y-text
1 sfloats var y-toff
1 sfloats var phi
1 sfloats var dphi
1 sfloats var rot-mode
cell var flip
cell var point#
[IFDEF] glarrays
cell var path
cell var #path
cell var #path'
cell var #path''
[ELSE]
cell var path
cell var path'
cell var path''
[THEN]
cell var matrix-stack
cell var smooth
cell var smooth'
cell var path-points
cell var gl-mode
0 var 'draw-path
defer draw-path
0 var 'do-texture
defer do-texture
0 var last-turtle
early scale
early scale-xyz
early left
early right
early up
early down
early roll-left
early roll-right
early x-left
early x-right
early y-left
early y-right
early z-left
early z-right
early forward-xyz
early forward
early degrees
early set-dphi
early get-xyz
early get-xy
early get-rpz
early get-rp
early get-rz
early get-r
early open-path
early start-path
early close-path
early end-path
early next-round
\ obsolete:
early open-round
early close-round
early finish-round
early set-xyz
early set-xy
early set-rpz
early set-rp
early set-r
early set-rz
early set
early set-light
early set-fog
early add-xyz
early add-xy
early add-rpz
early add-rp
early add-r
early add-rz
early add
early xy-text
early drop-point
early init-matrix
\ stacking, matrix transformation 28dec99py
early matrix>
early >matrix
early matrix@
early clone
early >turtle immediate
early turtle> immediate
early matrix*
early 1matrix
early pos@
early scale@
early ortho
\ drawing 30jan99py
early textured
early triangles
early textured-poly
early poly
early lines
early points
early textured-points
early textured-lines
\ auto-texturing 30jan99py
early xy-texture
early zphi-texture
early zphi2-texture
early rphi-texture
early zp-texture
early textures
early del-textures
early set-texture
early load-texture
early text-texture
early flip-clock
\ high level primitives 27dec99py
early segment
early cylinder
early sphere
\ debugging 30jan99py
\ early .trans
\ early set-normal
\ class implementation 03jan99py
class;
debugging class 3d-text
cell var w
cell var h
cell var wt
cell var ht
cell var texture
method draw
how:
: init ( w h wt ht texture -- )
texture ! ht ! wt ! h ! w ! ;
class;
3d-turtle implements
: init-matrix ( -- )
trans &12 sfloats erase
!1 trans-2,0 ( &02 sfloats + ) sf!
!1 trans-1,1 ( &05 sfloats + ) sf!
!-1 trans-3,2 ( &11 sfloats + ) sf! ;
: init-OpenGL ( -- )
GL_CW glFrontFace
GL_LESS glDepthFunc depth >r
GL_CULL_FACE GL_LIGHTING GL_DEPTH_TEST GL_NORMALIZE
depth r> - 0 ?DO glEnable LOOP
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST
glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST
glTexParameteri
GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_MODULATE glTexEnvi
GL_FOG_HINT GL_FASTEST glHint
GL_PERSPECTIVE_CORRECTION_HIN GL_FASTEST glHint
GL_POLYGON_SMOOTH_HINT GL_FASTEST glHint
GL_FRONT GL_FILL glPolygonMode
GL_LINE_SMOOTH glEnable
GL_FOG_DENSITY !0 glFogf
GL_FOG_COLOR .white glFogfv
GL_FOG_MODE GL_EXP2 glFogi ;
: init-device ( fnear ffar w h -- ) { f: near f: far w h }
0 0 w h glViewport
GL_PROJECTION glMatrixMode glLoadIdentity
GL_FOG_START near glFogf
GL_FOG_END far glFogf
w h > IF
w s>f h fm/ fdup fnegate fswap !-1 !1
ELSE
!-1 !1 h s>f w fm/ fdup fnegate fswap
THEN near far glFrustum
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT or glClear
GL_MODELVIEW glMatrixMode glLoadIdentity ;
: flip-clock ( -- ) flip @ 0= flip !
flip @ IF GL_CCW ELSE GL_CW THEN glFrontFace
glFlush ;
\ matrix operations 10jan99py
| $10 Constant maxstack
| &20 sfloats Constant /matrix
: matrix? ( -- ) matrix-stack @ 0=
IF [ /matrix maxstack * cell+ ] Literal
matrix-stack Handle! matrix-stack @ off
ELSE matrix-stack dup @ @
maxstack + 1+ -$10 and /matrix * cell+
SetHandleSize
THEN ;
: matrix-sp ( -- addr )
matrix? matrix-stack @ @+ swap /matrix * + ;
: >matrix ( -- )
trans matrix-sp /matrix move
1 matrix-stack @ +! ;
: matrix> ( -- )
-1 matrix-stack @ +!
matrix-sp trans /matrix move ;
: matrix@ ( -- )
matrix-sp /matrix - trans /matrix move ;
\ scale operations 10jan99py
: scale-xyz ( fx fy fz -- )
trans [ &12 sfloats ] Literal bounds
DO 2 I sfloat+ [ 3 sfloats ] Literal bounds
DO dup fpick I sf@ f* I sf! 1-
[ 1 sfloats ] Literal +LOOP drop
[ 4 sfloats ] Literal +LOOP fdrop fdrop fdrop ;
: scale ( f -- ) fdup fdup scale-xyz ;
\ rotation primitives 10jan99py
: do-rotate ( fs fc v1 v2 -- )
[ 3 sfloats ] Literal bounds
DO fover I sf@ f* fover dup sf@ f* f+ f-rot
fover dup sf@ f* fover I sf@ f*
fswap f- I sf! frot dup sf!
sfloat+ [ 1 sfloats ] Literal +LOOP
drop fdrop fdrop ;
: do-turn ( fs fc v1 v2 -- )
[ &12 sfloats ] Literal bounds
DO fover I sf@ f* fover dup sf@ f* f+ f-rot
fover dup sf@ f* fover I sf@ f*
fswap f- I sf! frot dup sf!
[ 4 sfloats ] Literal +
[ 4 sfloats ] Literal +LOOP
drop fdrop fdrop ;
\ turn operations 31dec98py
: phi>xy ( f -- f1 f2 )
rot-mode sf@ f* fsincos !1 f- !1 f+ ;
: degrees ( f -- ) 1/2pi f* rot-mode ! ;
: left ( f -- ) phi>xy trans-2,0 trans-3,0 do-turn ;
: down ( f -- ) phi>xy trans-1,0 trans-3,0 do-turn ;
: roll-left ( f -- ) phi>xy trans-1,0 trans-2,0 do-turn ;
: right ( f -- ) fnegate left ;
: up ( f -- ) fnegate down ;
: roll-right ( f -- ) fnegate roll-left ;
\ rotate operations 10jan99py
: x-left ( f -- ) phi>xy trans-1,1 trans-1,2 do-rotate ;
: y-left ( f -- ) phi>xy trans-1,0 trans-1,2 do-rotate ;
: z-left ( f -- ) phi>xy trans-1,0 trans-1,1 do-rotate ;
: x-right ( f -- ) fnegate x-left ;
: y-right ( f -- ) fnegate y-right ;
: z-right ( f -- ) fnegate z-left ;
\ simple operations 27dec98py
: forward-xyz ( fx fy fz -- )
fdup z-off sf@ f+ z-off sf!
trans [ &12 sfloats ] Literal bounds
DO 3 I sf@ I sfloat+ [ 3 sfloats ] Literal bounds
DO dup fpick I sf@ f* f+ 1-
[ 1 sfloats ] Literal +LOOP drop I sf!
[ 4 sfloats ] Literal +LOOP fdrop fdrop fdrop ;
: forward ( fz -- ) !0 !0 frot forward-xyz ;
\ complex operation 16feb99py
: matrix* ( -- ) -1 matrix-stack @ +!
trans-1,0 [ 3 sfloats ] Literal bounds
DO matrix-sp [ &12 sfloats ] Literal bounds
DO J !0 I sfloat+ [ 3 sfloats ] Literal bounds
DO dup sf@ I sf@ f* f+ [ 4 sfloats ] Literal +
[ 1 sfloats ] Literal +LOOP drop
[ 4 sfloats ] Literal +LOOP
fswap frot I [ &12 sfloats ] Literal bounds
DO I sf! [ 4 sfloats ] Literal +LOOP
[ 1 sfloats ] Literal +LOOP
trans matrix-sp [ &12 sfloats ] Literal bounds
DO I sf@ dup sf! [ 4 sfloats ] Literal +
[ 4 sfloats ] Literal +LOOP drop ;
: 1matrix ( -- ) >matrix init-matrix ;
\ point extraction 31dec98py
: pos@ ( -- fx fy fz )
trans-0,1 sf@
trans-0,0 sf@
trans-0,2 sf@ fnegate ;
: sqsum ( addr n -- )
!0 4* sfloats bounds
?DO I sf@ fdup f* f+ [ 4 sfloats ] Literal +LOOP ;
: scale@ ( -- fsx2 fsy2 fsz2 )
trans-1,0 3 sqsum
trans-2,0 3 sqsum
trans-3,0 3 sqsum ;
: get-xyz ( fx fy fz -- z' y' x' )
do-texture
trans-0,2 inner-get
trans-0,1 inner-get
trans-0,0 inner-get
fdrop fdrop fdrop ;
\ orthogonalize matrix 28dec99py
: ortho ( -- ) \ x x z -> y y x z -> x
scale@ { f: x f: y f: z |
trans-3,0 sf@ trans-3,1 sf@ trans-3,2 sf@
trans-1,0 sf@ trans-1,1 sf@ trans-1,2 sf@ cross*
trans-2,2 sf! trans-2,1 sf! trans-2,0 sf!
trans-2,0 sf@ trans-2,1 sf@ trans-2,2 sf@
trans-3,0 sf@ trans-3,1 sf@ trans-3,2 sf@ cross*
trans-1,2 sf! trans-1,1 sf! trans-1,0 sf!
x y z f* f/ y x z f* f/ fsqrt !1 scale-xyz } ;
\ points relative to current turtle position 03jan99py
: set-dphi ( fphi -- ) rot-mode sf@ f* dphi sf! ;
: get-xy ( fx fy -- z' y' x' ) !0 get-xyz ;
: get-rpz ( fr fphi fz -- z' y' x' )
f-rot rot-mode sf@ f* fdup phi sf! r,phi>xy frot get-xyz ;
: get-rp ( fr fphi -- z' y' x' ) !0 get-rpz ;
: get-rz ( fr fz -- z' y' x' )
fswap phi sf@ r,phi>xy frot get-xyz
dphi sf@ phi sf@ f+ phi sf! ;
: get-r ( fr -- z' y' x' ) !0 get-rz ;
\ path address 03jan99py
\ path layout:
\ oldpoint x y z tx ty nx ny nz
[IFDEF] glarrays
: path+ ( offset -- addr ) 9* 1+ cells path @ + ; macro
: cur-point ( n -- addr ) #path @ + path+ ; macro
: prev-point ( n -- addr ) #path' @ + path+ ; macro
| 9 cells Constant /point
[ELSE]
: cur-point ( n -- addr ) 9* 1+ cells path @ + ; macro
: prev-point ( n -- addr ) 9* 1+ cells path' @ + ; macro
: path+ cur-point ;
| 9 cells Constant /point
[THEN]
\ ligth 10jan99py
: set-light ( par1..4 par n -- ) GL_LIGHT0 +
dup glEnable >r >r
sp@ r> r> swap rot glLightfv 2drop 2drop ;
: set-fog ( fdensity -- )
fdup f0= IF fdrop GL_FOG glDisable EXIT THEN
GL_FOG_DENSITY glFogf GL_FOG glEnable ;
\ point setting 03jan99py
: path# path @ ; macro
: do-point ( z' y' x' -- )
point# @ path# @ path+ !point 1 path# +! ;
\ point setting 03jan99py
: drop-point ( -- ) 1 point# +! ;
: add-xyz ( fx fy fz -- ) get-xyz do-point ;
: add-xy ( fx fy -- ) get-xy do-point ;
: add-rpz ( fr fphi fz -- ) get-rpz do-point ;
: add-rp ( fr fphi -- ) get-rp do-point ;
: add-rz ( fr fz -- ) get-rz do-point ;
: add-r ( fr -- ) get-r do-point ;
: add ( -- ) !0 add-r ;
: set-xyz ( fx fy fz -- ) add-xyz drop-point ;
: set-xy ( fx fy -- ) add-xy drop-point ;
: set-rpz ( fr fphi fz -- ) add-rpz drop-point ;
: set-rp ( fr fphi -- ) add-rp drop-point ;
: set-rz ( fr fz -- ) add-rz drop-point ;
: set-r ( fr -- ) add-r drop-point ;
: set ( -- ) !0 set-r ;
\ path handling 03jan99py
: open-round ( -- )
[IFDEF] glarrays
#path' @ #path'' ! #path @ #path' !
2 path# +! path# @ #path !
[ELSE]
path'' @ IF path'' HandleOff THEN
path' @ IF path' @ path'' SetHandle path' off THEN
path @ IF path @ path' SetHandle path off THEN
path-points @ 4+ 9* 1+ cells dup path Handle!
path @ swap erase 1 path @ !
[THEN]
point# off ;
: open-path ( n -- )