\ 3D turtle graphics 27dec98py \needs float import float \needs glconst | import glconst [defined] x11 [IF] \needs xconst | import xconst [THEN] also memory also dos also float also glconst [defined] x11 [IF] also x11 [THEN] [defined] win32 [IF] also win32 [THEN] also opengl also [defined] win32 [IF] :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 [defined] ftuck 0= [IF] : ftuck fswap fover ; [THEN] [defined] f-rot 0= [IF] : f-rot frot frot ; [THEN] [defined] fover2 0= [IF] : fover2 2 fpick ; [THEN] [defined] f>fs 0= [IF] Variable 'f>fs : f>fs 'f>fs sf! 'f>fs @ ; [THEN] [defined] fs>f 0= [IF] : fs>f 'f>fs ! 'f>fs sf@ ; [THEN] [defined] %pi [IF] %pi FConstant pi [THEN] [defined] f**2 0= [IF] : f**2 fdup f* ; [THEN] [defined] fm*/ 0= [IF] : fm*/ s>f f/ s>f f* ; [THEN] [defined] r,phi>xy 0= [IF] : r,phi>xy ( r phi -- x y ) fsincos frot ftuck f* f-rot f* ; [THEN] [defined] 9* 0= [IF] [defined] VFXForth [IF] : 9* 9 * ; [ELSE] Code 9* AX AX *8 I) AX lea Next end-code macro [THEN] [THEN] [defined] 3* 0= [IF] : 3* dup 2* + ; macro [THEN] \ doesn't work for -1 : >2** ( a -- n ) 1 BEGIN 2dup u> WHILE 2* REPEAT nip ; [defined] VFXForth [IF] : 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] [defined] libGLU [IF] : >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: AX push AX push $C SP D) AX mov $C # AX add AX push ' glTexCoord2fv >c' A# AX mov A#) AX add AX call AX pop $C SP D) AX mov AX push ' glVertex3fv >c' A# AX mov A#) AX add AX call AX pop AX pop AX pop ret end-code Code glVertexNormalTexCoord3fv ( c:addr -- ) R: AX push AX push $C SP D) AX mov $C # AX add AX push ' glTexCoord2fv >c' A# AX mov A#) AX add AX call AX pop $C SP D) AX mov $14 # AX add AX push ' glNormal3fv >c' A# AX mov A#) AX add AX call AX pop $C SP D) AX mov AX push ' glVertex3fv >c' A# AX mov A#) AX add AX call AX pop AX pop AX pop ret end-code [THEN] 1e f>fs Constant #1. pi f2* FConstant tau tau 1/f FConstant 1/tau \ : .matrix ( addr -- ) \ &12 sfloats bounds \ DO cr I 4 sfloats bounds \ DO I sf@ 2e f+ 2e f- f. 1 sfloats +LOOP \ 4 sfloats +LOOP ; Create .white #1. , #1. , #1. , #1. , [defined] debug-points [IF] Variable maxpoints Variable #points $7FFFFFFF maxpoints ! : ?maxpoints ( addr -- ) #points @ maxpoints @ > IF drop rdrop THEN ; : points+ 1 #points +! ; [ELSE] : ?maxpoints ; immediate : 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# [defined] glarrays [IF] 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 create-mipmap1 early create-mipmap3 early create-mipmap4 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 1e trans-2,0 ( #02 sfloats + ) sf! 1e trans-1,1 ( #05 sfloats + ) sf! -1e 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 0e 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 -1e 1e ELSE -1e 1e 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 1e f- 1e f+ ; : degrees ( f -- ) 1/tau 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 -- ) 0e 0e 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 0e 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 -- ) 0e 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 1e 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' ) 0e 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' ) 0e 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' ) 0e get-rz ; \ path address 03jan99py \ path layout: \ oldpoint x y z tx ty nx ny nz [defined] glarrays [IF] : 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 ( -- ) 0e 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 ( -- ) 0e set-r ; \ path handling 03jan99py : open-round ( -- ) [defined] glarrays [IF] #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 -- ) smooth @ dup smooth' @ <> IF dup IF GL_SMOOTH ELSE GL_FLAT THEN glShadeModel THEN smooth' ! \ ugly workaround path-points ! open-round ; : fs- ( fs1 fs2 -- fs3 ) fs>f fs>f f- f>fs ; macro : look-at ( -- z' y' x' ) trans-3,2 sf@ f>fs trans-3,1 sf@ f>fs trans-3,0 sf@ f>fs ; : look-back ( -- z' y' x' ) trans-3,2 sf@ fnegate f>fs trans-3,1 sf@ fnegate f>fs trans-3,0 sf@ fnegate f>fs ; : start-path ( n -- ) look-back { z y x } dup open-path 0 ?DO add LOOP path-points @ 2+ 1 ?DO z y x I path+ !normal LOOP ; \ auto-texturing 30jan99py : !text ( x y -- ) swap path# @ path+ 4 cells + 2! ; : x-text@ ( f -- tx ) x-text 2linear ; : y-text@ ( f -- tx ) y-text 2linear ; : xy-text ( fx fy -- ) y-text@ x-text@ swap !text ; : do-xy-text ( fx fy fz -- fx fy fz ) fover2 x-text@ fover y-text@ !text ; : do-zphi-text ( fx fy fz -- fx fy fz ) fdup z-off sf@ f+ x-text@ fover2 fover2 fswap fatan2 y-text@ !text ; : do-zphi2-text ( fx fy fz -- fx fy fz ) fdup z-off sf@ f+ x-text@ phi sf@ y-text@ !text ; : do-zp-text ( fx fy fz -- fx fy fz ) fdup z-off sf@ f+ x-text@ point# @ s>f y-text@ !text ; : do-rphi-text ( fx fy fz -- fx fy fz ) fover2 f**2 fover2 f**2 f+ fsqrt x-text@ fover2 fover2 fswap fatan2 y-text@ !text ; : >texture ( addr f -- ) IS do-texture y-text sf! 0e z-off sf! ; : xy-texture ['] do-xy-text 1e >texture ; : zphi-texture ['] do-zphi-text 1/tau >texture ; : zphi2-texture ['] do-zphi2-text 1/tau >texture ; : zp-texture ['] do-zp-text 1e >texture ; : rphi-texture ['] do-rphi-text 1/tau >texture ; : no-texture ['] noop 1e >texture ; \ texture loading (ppm) 31jan99py : textures ( n -- t1 .. tn ) ?texture [IF] dup >r 0 ?DO 0 LOOP sp@ r> swap glGenTextures [ELSE] 0 ?DO 0 LOOP [THEN] ; : del-textures ( t1 .. tn n -- ) ?texture [IF] >r sp@ r@ swap glDeleteTextures r> [THEN] 0 ?DO drop LOOP ; : set-texture ( n -- ) ?texture [IF] GL_TEXTURE_2D swap glBindTexture ; [ELSE] drop ; [THEN] : create-mipmap1 ( addr w h -- addr ) 0 { w h n } BEGIN dup >r GL_TEXTURE_2D n GL_ALPHA8 w h 0 GL_ALPHA GL_UNSIGNED_BYTE r> glTexImage2D w 1 > h 1 > and do-mipmap and IF dup dup h w * bounds ?DO I w bounds ?DO I c@ I 1+ c@ + I w + c@ + I w + 1+ c@ + 4/ swap c!+ 2 +LOOP w 2* +LOOP drop w 2/ to w h 2/ to h n 1+ to n false ELSE true THEN UNTIL ; : create-mipmap3 ( addr w h -- addr ) over 3* 0 { w h w3 n } BEGIN dup >r GL_TEXTURE_2D n GL_RGB8 w h 0 GL_BGR GL_UNSIGNED_BYTE r> glTexImage2D w 1 > h 1 > and do-mipmap and IF dup dup h w3 * bounds ?DO I w3 bounds ?DO I c@ I 3+ c@ + I w3 + c@ + I w3 + 3+ c@ + 4/ swap c!+ I 1+ c@ I 4+ c@ + I 1+ w3 + c@ + I w3 + 4+ c@ + 4/ swap c!+ I 2+ c@ I 5 + c@ + I 2+ w3 + c@ + I w3 + 5 + c@ + 4/ swap c!+ 6 +LOOP w3 2* +LOOP drop w 2/ to w h 2/ to h w3 2/ to w3 n 1+ to n false ELSE true THEN UNTIL ; : create-mipmap4 ( addr w h -- addr ) over 4* 0 { w h w4 n } BEGIN dup >r GL_TEXTURE_2D n GL_RGBA w h 0 GL_BGRA GL_UNSIGNED_BYTE r> glTexImage2D w 1 > h 1 > and do-mipmap and IF dup dup h w4 * bounds ?DO I w4 bounds ?DO I c@ I 4+ c@ + I w4 + c@ + I w4 + 4+ c@ + 4/ swap c!+ I 1+ c@ I 5 + c@ + I 1+ w4 + c@ + I w4 + 5 + c@ + 4/ swap c!+ I 2+ c@ I 6 + c@ + I 2+ w4 + c@ + I w4 + 6 + c@ + 4/ swap c!+ I 3+ c@ I 7 + c@ + I 3+ w4 + c@ + I w4 + 7 + c@ + 4/ swap c!+ 8 +LOOP w4 2* +LOOP drop w 2/ to w h 2/ to h w4 2/ to w4 n 1+ to n false ELSE true THEN UNTIL ; : load-texture-ppm ( fd -- ) ?texture [IF] >r scratch $100 r@ read-line throw 2drop scratch $100 BEGIN drop dup $100 r@ read-line throw drop over c@ '#' <> UNTIL 0. 2swap >number 1 /string 0. 2swap >number 2drop drop nip scratch $100 r@ read-line throw 2drop ( w h ) 2dup * 3 * dup NewPtr tuck swap r@ read-file throw drop r> close-file throw ( w h addr ) -rot over2 over2 over2 * 3* <>.24 create-mipmap3 DisposPtr [ELSE] close-file throw [THEN] ; [defined] has-png [IF] : load-texture-png ( fd -- ) \ & pngflags push $0015 to pngflags read-png-image 4 and IF create-mipmap4 ELSE create-mipmap3 THEN DisposPtr ; [THEN] : load-texture ( addr u -- ) [defined] has-png [IF] s" .png" suffix? IF load-texture-png EXIT THEN [ELSE] s" .ppm" suffix? IF load-texture-ppm EXIT THEN 2drop [THEN] ; \ text drawing 23jul2005py [defined] xft [IF] also xconst also xft : map>addrwh ( image -- addr w h ) >r r@ XImage data @ r@ XImage width @ r> XImage height @ ; : text-texture ( addr u font-object -- text-o ) 1 textures dup >r set-texture font with 2dup size 2swap 2over >2** swap >2** swap 2swap 2over 8 -rot pixmap new >r $10 color ! r@ displays with xywh $10 box endwith 0 0 r@ draw r> endwith ( greymap ) pixmap with get 2drop dispose endwith dup >r map>addrwh create-mipmap1 r> XDestroyImage drop r> 3d-text new ; previous previous [THEN] \ normalization 03jan99py : set-normal ( vl v vr -- ) get-normal flip @ IF negate3 THEN glNormal3f ; : set-normal+! ( vl v vr -- ) over >r get-normal flip @ IF negate3 THEN r> .nz f+ .nzsf! ( z ) .ny f+ .nysf! ( y ) .nx f+ .nxsf! ( x ) drop ; \ point access 27feb99py : point ( -- addr ) cell+ ; macro : prevpoint ( -- addr ) [ /point negate cell+ ] Literal + ; macro : nextpoint ( -- addr ) [ /point cell+ ] Literal + ; macro : oldpoint ( addr -- addr ) @ 9* cells + ; macro : oldprevpoint ( addr -- addr ) /point - @ 9* cells + ; macro : oldnextpoint ( addr -- addr ) /point + @ 9* cells + ; macro \ texture path primitives 25feb99py : path-bound ( p' p p+ -- pold pnewhi pnewlo ) [defined] glarrays [IF] >r swap path+ cell+ swap 1- path+ r> 2- path+ swap ; [ELSE] drop swap $B cells + swap @+ /point + swap 9* cells bounds ; [THEN] : compute-normals ( p' p p+ -- p ) path-bound ?DO I point over I oldpoint over2 I oldprevpoint set-normal+! dup I oldnextpoint over I oldpoint I point set-normal+! I prevpoint I point over2 I oldpoint set-normal+! dup I oldpoint I point I nextpoint set-normal+! /point +LOOP drop ; : flat-vertex ( addr -- ) ?maxpoints glVertex3fv ; : text-vertex ( addr -- ) ?maxpoints dup $C + glTexCoord2fv glVertex3fv ; : text-normal-vertex ( addr -- ) ?maxpoints dup $C + glTexCoord2fv dup $14 + glNormal3fv glVertex3fv ; : normal-vertex ( addr -- ) ?maxpoints dup $14 + glNormal3fv glVertex3fv ; : normal-1 ( addr i -- addr ) 1 bounds DO I point over I oldpoint over2 I oldprevpoint LOOP set-normal ; : normal-2 ( addr i -- addr ) 1 bounds DO I prevpoint I point over2 I oldpoint LOOP set-normal ; \ path drawing 27feb99py : draw-textured-path ( p'' p' p -- ) gl-mode @ glBegin dup [defined] glarrays [IF] path+ [THEN] #15 cells + dup @ #1. = IF off ELSE drop THEN 2dup <> smooth @ and IF 2dup path# @ 1+ compute-normals THEN path-bound smooth @ IF ?DO dup I oldpoint text-normal-vertex I point text-normal-vertex points+ /point +LOOP ELSE ?DO I normal-1 dup I oldpoint text-vertex I normal-2 I point text-vertex points+ /point +LOOP THEN drop glEnd ; : draw-triangle-path ( p'' p' p -- ) gl-mode @ glBegin 2dup <> smooth @ and IF 2dup path# @ 2+ compute-normals THEN path-bound smooth @ IF ?DO dup I oldpoint normal-vertex I point normal-vertex points+ /point +LOOP ELSE ?DO I normal-1 dup I oldpoint flat-vertex I normal-2 I point flat-vertex points+ /point +LOOP THEN drop glEnd ; : draw-point-path ( p'' p' p -- ) gl-mode @ glBegin path-bound ?DO I normal-2 I point flat-vertex points+ /point +LOOP drop glEnd ; : draw-textured-point-path ( p'' p' p -- ) gl-mode @ glBegin path-bound ?DO ( I normal-2 ) I point text-vertex points+ /point +LOOP drop glEnd ; : draw-line-path ( p'' p' p -- ) gl-mode @ glBegin path-bound ?DO I normal-1 dup I oldpoint flat-vertex dup I oldprevpoint flat-vertex I normal-2 dup I oldpoint flat-vertex I point flat-vertex points+ /point +LOOP drop glEnd ; : draw-textured-line-path ( p'' p' p -- ) gl-mode @ glBegin path-bound ?DO I normal-1 dup I oldpoint text-vertex dup I oldprevpoint text-vertex I normal-2 dup I oldpoint text-vertex I point text-vertex points+ /point +LOOP drop glEnd ; \ polygon tesselation [defined] libGLU [IF] : draw-textured-poly-path ( p'' p' p -- ) [defined] gluNewTess [IF] 0e 0e 0e get-xyz >r >r >r 0e 0e 1e get-xyz fs>f r> fs>f f- fs>f r> fs>f f- fs>f r> fs>f f- f>fs f>fs f>fs { nx ny nz } gluNewTess >r r@ GLU_TESS_VERTEX ['] glVertexNormalTexCoord3fv gluTessCallback r@ GLU_TESS_BEGIN ['] glBegin >c gluTessCallback r@ GLU_TESS_EDGE_FLAG ['] glEdgeFlag >c gluTessCallback r@ GLU_TESS_END ['] glEnd >c gluTessCallback r@ GLU_TESS_ERROR ['] noop gluTessCallback \ r@ GLU_TESS_WINDING_RULE GLU_TESS_WINDING_POSITIVE s>f gluTessProperty r@ 0 gluTessBeginPolygon r@ gluTessBeginContour path-bound 2dup - /point / 3* dfloats NewPtr r> swap dup >r 2swap ?DO I point nx ny nz 3 pick !normal sf@+ swap df!+ swap sf@+ swap df!+ swap sf@+ swap df!+ nip -3 dfloats + 2dup I point gluTessVertex points+ /point +LOOP >r >r drop r@ gluTessEndContour r@ gluTessEndPolygon r> rdrop r> DisposPtr gluDeleteTess [ELSE] gl-mode @ glBegin path-bound ?DO I point text-vertex points+ /point +LOOP drop glEnd [THEN] ; [THEN] \ drawing modes 25feb99py : textured ( -- ) ['] draw-textured-path IS draw-path GL_TEXTURE_2D glEnable GL_QUAD_STRIP gl-mode ! ; [defined] libGLU [IF] : textured-poly ( -- ) ['] draw-textured-poly-path IS draw-path GL_TEXTURE_2D glEnable GL_POLYGON gl-mode ! ; : poly ( -- ) ['] draw-textured-poly-path IS draw-path GL_TEXTURE_2D glDisable GL_POLYGON gl-mode ! ; [THEN] : triangles ( -- ) ['] draw-triangle-path IS draw-path GL_TEXTURE_2D glDisable GL_QUAD_STRIP gl-mode ! ; : points ( -- ) ['] draw-point-path IS draw-path GL_TEXTURE_2D glDisable GL_POINTS gl-mode ! ; : textured-points ( -- ) ['] draw-textured-point-path IS draw-path GL_TEXTURE_2D glEnable GL_POINTS gl-mode ! ; : lines ( -- ) ['] draw-line-path IS draw-path GL_TEXTURE_2D glDisable GL_LINES gl-mode ! ; : textured-lines ( -- ) ['] draw-textured-line-path IS draw-path GL_TEXTURE_2D glEnable GL_LINES gl-mode ! ; \ close pathes and rounds 30jan99py : finish-round ( -- ) -1 path# +! [defined] glarrays [IF] path# @ 1- path+ #path @ 1- path+ /point move #path'' @ IF #path'' @ #path' @ #path @ draw-path THEN #path'' off [ELSE] path# @ 1- path+ path @ cell+ /point move path'' @ IF path'' @ path' @ path @ draw-path path'' HandleOff THEN [THEN] ; : close-round ( -- ) [defined] glarrays [IF] #path @ path+ path# @ path+ /point 2* move #path' @ [ELSE] path @ @+ /point + swap path+ /point 2* move path' @ [THEN] IF point# @ path# @ path+ ! THEN 1 path @ +! finish-round ; : next-round ( -- ) close-round open-round ; [defined] glarrays [IF] : close-path ( -- ) #path'' @ IF close-round THEN #path' @ IF #path' @ #path @ dup draw-path THEN #path'' off #path' off #path off 0 path# ! ; [ELSE] : close-path ( -- ) path'' @ IF close-round THEN path' @ IF path' @ path @ dup draw-path THEN path @ IF path HandleOff THEN path' @ IF path' HandleOff THEN path'' @ IF path'' HandleOff THEN ; [THEN] : end-path ( -- ) look-at { z y x } next-round path-points @ 0 ?DO set LOOP close-round path-points @ 2+ 1 ?DO z y x I path+ !normal LOOP close-path ; \ debugging aids 03jan99py \ : .trans trans .matrix ; \ cloning 14feb99py | Variable clone-init : clone-handle ( addr -- ) dup @ 0= IF drop EXIT THEN >r r@ @ r@ GetHandleSize dup r@ Handle! r> @ swap move ; : clone ( -- o ) [defined] glarrays [IF] #path'' @ IF close-round THEN [ELSE] path'' @ IF close-round THEN [THEN] clone-init on trans 3d-turtle new 3d-turtle with trans last-turtle over - move path clone-handle [defined] glarrays [ 0= ] [IF] path' clone-handle path'' off [THEN] matrix-stack clone-handle ^ endwith clone-init off ; : >turtle ( -- ) postpone clone postpone with ; : turtle> ( -- ) postpone dispose postpone endwith ; \ high level primitives 27dec99py : segment ( r d n -- ) forward { f: r } next-round 0 DO r set-r LOOP ; : sphere ( r n -- ) pi dup fm/ set-dphi dup 2* start-path dup 1 DO >matrix I' pi I I' fm*/ fover f>r fsincos f>r fover f* fswap 1e fr> f- f* 2* segment fr> matrix> LOOP f2* forward drop end-path ; : cylinder ( r1 r2 d n -- ) { f: r1 f: r2 f: d } tau dup fm/ set-dphi dup start-path r1 .01e f* 0e dup segment \ ugly workaround r1 0e dup segment r1 0e dup segment r2 d dup segment r2 0e segment end-path ; \ init and dispose 10jan99py : init ( fnear ffar w h / -- ) clone-init @ ?EXIT [defined] debug-points [IF] #points off [THEN] [defined] glarrays [IF] [ $8000 4+ 9* cells ] Literal path Handle! 0 path# ! [THEN] 1e x-text sf! 1e y-text sf! 1e rot-mode sf! init-matrix init-OpenGL init-device triangles no-texture ; : dispose ( -- ) close-path [defined] glarrays [IF] path @ IF path HandleOff THEN [THEN] matrix-stack @ IF matrix-stack HandleOff THEN super dispose ; class; 3d-text implements : draw ( dx dy dpy -- ) 3d-turtle with r> smooth push smooth off z-off push x-text push y-text push x-toff push y-toff push 'draw-path push 'do-texture push GL_TEXTURE_2D glIsEnabled >r >r ^ endwith >r w @ s>f wt @ fm/ h @ s>f ht @ fm/ .005e w @ fm* .005e h @ fm* 1e texture @ r> 3d-turtle with set-texture textured xy-texture >matrix scale-xyz swap s>f f2/ fnegate s>f f2/ fnegate 0e forward-xyz y-text sf! x-text sf! 0e fdup x-toff sf! y-toff sf! 3 open-path 0e 0e set-xy 0e 1e set-xy next-round 1e 0e set-xy 1e 1e set-xy next-round close-path matrix> endwith GL_TEXTURE_2D r> IF glEnable ELSE glDisable THEN ; class; previous previous previous previous previous previous previous