IF INKEY$(-256)="W" INSTALL @lib$+"D3DLIBA" ELSE INSTALL @lib$+"OGLLIB"
PROCgraphics(1000,800)
DIM l%(0), b%(1), n%(1), f%(1), s%(1), m%(1), t%(1), y(1), p(1), r(1), X(1), Y(1), Z(1), e(2), a(2)
ON CLOSE PROCcleanup:QUIT
ON ERROR PROCcleanup:PRINT REPORT$:END
IF INKEY$(-256)="W" d% = FN_initd3d(@hwnd%, 1, 0) ELSE d% = FN_initgl(@hwnd%, 1, 0)
IF d% = 0 ERROR 100, "Can't initialise Direct3D"
e() = 0, 0, -6
a() = 0, 0, 0
l%()=1
REPEAT
PROCcreate3d
b%(0) = FN_load3d(d%, @dir$+"TRIANGLE.B3D", n%(0), f%(0), s%(0))
IF b%(0) = 0 ERROR 100, "Can't load TRIANGLE.B3D"
REM t%(1) = FN_loadtexture(d%, @dir$+"purple.JPG")
REM IF t%(1) = 0 ERROR 100, "Can't load face.JPG"
y() +=.01:REM yaw (rotations around the Y axis)
REM pitch
p() =0:REM TIME/100 (pitch angles rotations around the X axis)
REM roll
r() = 0:REM TIME/40 (roll angles (rotations around the Z axis)
REM X (right left)
X() = 0:REM SIN(TIME/200)
REM Y() up and down
Y() = 0
REM Z() depth
Z() = 10:REM
REM PROC_render(d%, &FF7F7F7F, 0, l%(), 2, m%(), t%(), b%(), n%(), f%(), s%(), y(), p(), r(), X(), Y(), Z(), e(), a(), PI/4, 5/4, 1, 1000)
PROC_render(d%, &FF000000, 0, l%(), 2, m%(), t%(), b%(), n%(), f%(), s%(), y(), p(), r(), X(), Y(), Z(), e(), a(), PI/4, 5/4, 1, 1000, 0) :REM experimental
WAIT 3
REM 1 2 3 4 5 6 7 8 9 10 11 yaw pitch roll X Y Z eye0123 18 19 20 ^mcd ^( cam to farplane dist)
REM 1 Val returned from FN_init3D
REM 2 back color 3 #of lights 4 light pointers
REM t%() - holds texture
REM mcd - minimum near cam distance
WAIT 1
UNTIL FALSE
END
DEF PROCcleanup
t%(1) += 0:IF t%(1) PROC_release(t%(1))
b%(0) += 0:IF b%(0) PROC_release(b%(0))
b%(1) += 0:IF b%(1) PROC_release(b%(1))
d% += 0 :IF d% PROC_release(d%)
ENDPROC
DEF PROCcreate3d
F% = OPENOUT"TRIANGLE.B3D"
PROC4(6):REM 3 vertices
PROC4(&100042):REM vertex size &10 and format &42
res$=""
res=0
ls= 0
LET rs= 24
counl%=290
counr%=2110
REM setup buttons before use
REM x , y ,size,"fillcolor","command"
res$=FNabutton(100,100,25,"light green","fill"):REM keeping it efficient
res$=FNabutton(125,130,25,"yellow","fill")
res$=FNabutton(300,100,25,"red","fill")
res$=FNabutton(300,130,25,"cyan","fill")
res$=FNabutton(500,100,25,"200,200,190","fill")
res$=FNabutton(470,100,25,"200,190,200","fill")
res$=FNabutton(593,70,75,"000,000,000","fill") :REM select entire triangle
res$=FNabutton(770,90,25,"100,50,100","fill") :REM LL triangle only
res$=FNabutton(905,90,25,"50,100,50","fill"):REM LR triangle only
res$=FNabutton(835,205,25,"200,50,100","fill"):REM TOP triangle only
PROCcolor("f","white")
LINE165,165,200,200:LINE200,200,180,200:LINE 200,200,200,180
LINE 90,90,60,60:LINE 60,60,80,60:LINE 60,60,60,80
LINE 315,170,315,200:LINE 315,200,300,180:LINE 315,200,330,180
LINE 315,85,315,50:LINE 315,50,300,70:LINE 315,50,330,70
LINE 460,115,430,115:LINE 430,115,440,130:LINE 430,115,440,100:LINE 535,115,560,115
LINE 560,115,550,130:LINE 560,115,550,100:LINE 600,100,660,100:LINE 660,100,630,130
LINE 630,130,600,100: LINE 800,100,900,100:LINE 900,100,850,200:LINE 850,200,800,100
PROCcolor("f","black")
REM TRACKING STARTS HERE
res$=""
IF FNabutton(100,100,25,"green","out")="out" THEN res$="out"
IF FNabutton(125,130,25,"blue","in")="in" THEN res$="in"
IF FNabutton(300,100,25,"red","down")="down" THEN res$="down"
IF FNabutton(300,130,25,"orange","up")="up" THEN res$="up"
IF FNabutton(500,100,25,"purple","right")="right" THEN res$="right"
IF FNabutton(470,100,25,"200,190,200","left")="left" THEN res$="left"
IF FNabutton(593,70,75,"000,000,000","all")="all" THEN res$="all"
IF FNabutton(770,90,25,"100,50,100","LL")="LL" THEN res$="LL" :REM LL triangle only
IF FNabutton(905,90,25,"50,100,50","LR")="LR" THEN res$="LR":REM LR triangle only
IF FNabutton(835,205,25,"200,50,100","TOP")="TOP" THEN res$="TOP":REM TOP triangle only
REM PROCsbox(10,1000,2000,900,"15")
REM MOVE 30,950:PRINT "3D design tool :" +res$
WAIT 2
REM LL x LL y LL z
PROC4(FN_f4(-1.0)):PROC4(FN_f4(-1.0)):PROC4(FN_f4(1.0)):PROC4(&FF0000FF)
REM LR x LR y LR z
PROC4(FN_f4(1.0)):PROC4(FN_f4(-1.0)):PROC4(FN_f4(1.0)):PROC4(&FF0000FF):REM PROC4(&FF00FF00)
REM PEAK X PEAK Y PEAK Z
PROC4(FN_f4(1.0)):PROC4(FN_f4(1.0)):PROC4(FN_f4(1.0)):PROC4(&FF0000FF):REM PROC4(&FFFF0000)
PROC4(FN_f4(-1.0)):PROC4(FN_f4(-1.0)):PROC4(FN_f4(1.0)):PROC4(&FF0000FF):REM PROC4(&FF0000FF)
REM LR x LR y LR z
PROC4(FN_f4(-1)):PROC4(FN_f4(1.0)):PROC4(FN_f4(1.0)):PROC4(&FF0000FF):REM PROC4(&FF00FF00)
REM PEAK X PEAK Y PEAK Z
PROC4(FN_f4(1.0)):PROC4(FN_f4(1.0)):PROC4(FN_f4(1.0)):PROC4(&FF0000FF):REM PROC4(&FFFF0000)
CLOSE #F%
ENDPROC
DEF PROC4(A%):BPUT#F%,A%:BPUT#F%,A%>>8:BPUT#F%,A%>>16:BPUT#F%,A%>>24:ENDPROC
REM x,y is lower left and c$=fillcolor:com$-command
DEFFNabutton(x,y,size%,c$,com$)
MOUSE mx,my,mb
LOCAL ret$
PROCcolor("f","5")
PROCrect(x,y,x+size%,y+size%)
IF com$="fill" THEN
PROCpaint(x+5,y+5,c$)
ENDIF
IF mx>x AND mx<x+size% AND my>y AND my<y+size% THEN
PROCcolor("f","15"):PROCrect(x,y,x+size%,y+size%)
IF mb=4 THEN ret$=com$
ENDIF
=ret$
DEFPROCarrowu(x,y)
PRIVATE xx,yy
PROCcolor("f","black")
LINE xx,yy,xx-20,yy-20
LINE xx,yy,xx+20,yy-20
PROCcolor("f","15")
LINE x,y,x-20,y-20
LINE x,y,x+20,y-20
xx=x:yy=y
ENDPROC
DEFPROCarrowd(x,y)
PRIVATE hh,vv
PROCcolor("f","000,000,000")
LINE hh,vv,hh-20,vv+20
LINE hh,vv,hh+20,vv+20
PROCcolor("f","15")
LINE x,y,x-20,y+20
LINE x,y,x+20,y+20
hh=x:vv=y
ENDPROC
REM GRAPHICS(x,y)
DEF PROCgraphics(x,y)
VDU 23,22,x;y;8,15,16,1
OFF
VDU 5
ENDPROC
REM SBOX **********************
DEF PROCsbox(x%,y%,w%,h%,c$)
LOCAL ry%,sx%,sy%
sx%=x%:sy%=y%
IF x%>w% THEN x%=w%:w%=sx%
IF y%>h% THEN y%=h%:h%=sy%
ry%=y%
PROCcolor("f",c$)
REPEAT
LINE x%,y%,w%,y%
y%=y%+1
UNTIL y%=h%
y%=ry%
IF c$<>"0" THEN PROCcolor("f","000,000,000") ELSE PROCcolor("f","white")
LINE x%+2,y%+2,w%-2,y%+2
LINE w%-2,y%+2,w%-2,h%-4
LINE w%-2,h%-4,x%+2,h%-4
LINE x%+2,h%-4,x%+2,y%+2
PROCresetrgb
ENDPROC
REM RECT **********************
DEFPROCrect(x%,y%,w%,h%)
LOCAL sx%,sy%
sx%=x%:sy%=y%
IF x%>w% THEN x%=w%:w%=sx%
IF y%>h% THEN y%=h%:h%=sy%
LINE x%,y%,w%,y%
LINE w%,y%,w%,h%
LINE w%,h%,x%,h%
LINE x%,h%,x%,y%
ENDPROC
REM pixel *******************
DEFPROCpixel(x%,y%,c$)
PROCcolor("f",c$)
MOVE x%,y%:DRAW x%,y%
ENDPROC
REM SET c$ can be colors like blue or 1 or a R,G,B color
DEF PROCset(x%,y%,c$)
LOCAL h%
PROCcolor("f",c$)
FOR h%=0 TO 20
LINE x%+h%,y%,x%+h%,y%+20
NEXT
MOVE 0,0
ENDPROC
DEFPROCpaint(x%,y%,co$)
PROCcolor("b","0"):PROCcolor("f",co$)
FILL x%,y%
ENDPROC
REM restore default color palettes
DEFPROCresetrgb
COLOUR 0,0,0,0 :COLOUR 1,200,0,0 :COLOUR 2,000,200,000
COLOUR 3,200,200,000:COLOUR 4,000,000,200:COLOUR 5,200,000,200
COLOUR 6,000,200,200:COLOUR 7,200,200,200:COLOUR 8,056,056,056
COLOUR 9,248,056,056:COLOUR 10,056,248,056:COLOUR 11,248,248,056
COLOUR 12,056,056,248:COLOUR 13,248,056,248:COLOUR 14,056,248,248
COLOUR 15,248,248,248
ENDPROC
DEF PROCcolor(fb$,rgb$)
PRIVATE assemble$,br%,bg%,bb%
IF rgb$="0" OR rgb$="black" THEN rgb$="000,000,000"
IF rgb$="1" OR rgb$="red" THEN rgb$="200,000,000"
IF rgb$="2" OR rgb$="green" THEN rgb$="000,200,000"
IF rgb$="3" OR rgb$="yellow" THEN rgb$="200,200,000"
IF rgb$="4" OR rgb$="blue" THEN rgb$="000,000,200"
IF rgb$="5" OR rgb$="magenta" THEN rgb$="200,000,200"
IF rgb$="6" OR rgb$="cyan" THEN rgb$="000,200,200"
IF rgb$="7" OR rgb$="white" THEN rgb$="200,200,200"
IF rgb$="8" OR rgb$="grey" THEN rgb$="056,056,056"
IF rgb$="9" OR rgb$="light red" THEN rgb$="248,056,056"
IF rgb$="10" OR rgb$="light green" THEN rgb$="056,248,056"
IF rgb$="11" OR rgb$="light yellow" THEN rgb$="248,248,056"
IF rgb$="12" OR rgb$="light blue" THEN rgb$="056,056,248"
IF rgb$="13" OR rgb$="light magenta" THEN rgb$="248,056,248"
IF rgb$="14" OR rgb$="light cyan" THEN rgb$="056,248,248"
IF rgb$="15" OR rgb$="light white" THEN rgb$="248,248,248"
assemble$=rgb$
br%=VAL(MID$(assemble$,1,3)):bg%=VAL(MID$(assemble$,5,3)):bb%=VAL(MID$(assemble$,9,3))
IF fb$="f" OR fb$="F" THEN COLOUR 0,br%,bg%,bb% : GCOL 0
IF fb$="b" OR fb$="B" THEN COLOUR 1,br%,bg%,bb% : GCOL 128+1
ENDPROC