ACETAMINOPHEN

[DrChip]

REM ACETAMINOPHEN
REM You'll need some afterwards
REM iPhone 6 plus
REM enjoy
REM the shapes in the blue
REM to get a cool effect!!
notes stop
notes load "/Examples/10. Music & Sound/files/test5.mid"
notes play

graphics
'Program Notes: This demo started life as a wire frame
'3D routine that I developed to model a simple 3D cube....
'My previous 3D had depth sorted faces, this one uses a
'hidden line algorithm that checks if the points of a given
'face are in clockwise or
'anticlockwise order to see if they should
'be drawn.... I Added some light sourcing
'to the cube, and borrowed an idea from
'my other demos.

'Set Everything up
GOSUB initialize

' Main Loop
loop:
refresh off
graphics clear 0,0,0
'set colors
fill COLOR .50,.100,.100
'Draw Backround
'triangle 0,0 to scw,sch to 0,sch
trix(0)=0
triy(0)=0
trix(1)=sw
triy(1)=sh
trix(2)=0
triy(2)=sh
fill poly trix, triy count 3
'triangle 0,0 to scw,sch to scw,0
trix(0)=0
triy(0)=0
trix(1)=sw
triy(1)=sh
trix(2)=sw
triy(2)=0
fill poly trix, triy count 3

'Call Rotation Routine
GOSUB rotate

'Draw Inside Faces
'Color 10,30,10
f1=1
f2=2
f3=3
f4=4 'Face 1
GOSUB draw 'Draw Face 1
f1=5
f2=8
f3=7
f4=6 'Face 2
GOSUB draw 'Draw Face 2
f1=6
f2=2
f3=1
f4=5 'Face 3
GOSUB draw 'Draw Face 3
f1=8
f2=4
f3=3
f4=7 ' Face 4
GOSUB draw 'Draw Face 4
f1=2
f2=6
f3=7
f4=3 'Face 5
GOSUB draw 'Draw Face 5
f1=8
f2=5
f3=1
f4=4 'Face 6
GOSUB draw 'Draw Face 6

' Draw Outside Faces
f1=1
f2=2
f3=3
f4=4 'Face 1
GOSUB draw2 'Draw Face 1
f1=5
f2=8
f3=7
f4=6 'Face 2
GOSUB draw2 'Draw Face 2
f1=6
f2=2
f3=1
f4=5 'Face 3
GOSUB draw2 'Draw Face 3
f1=8
f2=4
f3=3
f4=7 'Face 4
GOSUB draw2 'Draw Face 4
f1=2
f2=6
f3=7
f4=3 'Face 5
GOSUB draw2 'Draw Face 5
f1=8
f2=5
f3=1
f4=4 'Face 6
GOSUB draw2 'Draw Face 6

'Display Text
stext$=substr$(s$,p,len(s$)-1)
draw COLOR 0,0,0
DRAW TEXT "ACETAMINOPHEN" at 0,2
DRAW TEXT stext$ at scx+2,sch-18
draw COLOR 1,1,1
DRAW TEXT "ACETAMINOPHEN" at 0,0
'DRAW TEXT stext$ at scx,sch-20

'Scroller Code


ls=len(s$)-1
text$=substr$(s$,p,ls)
draw color 0,0,0
draw text text$ at scx+2,sh-18
draw color 1,1,1
draw text text$ at scx,sh-20


'draw text substr$(s$,p,ls) at scx,texty
scx-=1
if scx<-50 then
scx+=10
p+=1
if p>ls then p=1
end if


GOSUB writer
refresh on
GOTO loop
'Main Loop Ends

'Subroutines

'This Subroutine Does The Bouncy Greetings Thing;

writer:
mm=mm+.05
IF mm>4 THEN
mm=0
mc=mc+1
IF mc>messages THEN
mc=1
END IF
END IF
draw COLOR 1,1,1
DRAW TEXT m$(mc) at csw-LEN(m$(mc))*5,70*SIN(mm)
RETURN

'Subroutine To Draw One Inner Face From 4 Passed Points
'This Will Only Draw The Face If It Is Behind.

draw:
'Calculate Poly Positions And Draw One Complete Face

'Hidden Line Removal Algorithm
vx1= tx(f1)-tx(f2)
vy1= ty(f1)-ty(f2)
vx2= tx(f3)-tx(f2)
vy2= ty(f3)-ty(f2)
IF (vx1*vy2)-(vx2*vy1)>0 THEN

'Lightsource Color
light=(tz(1)+tz(f2)+tz(f3)+tz(f4)*3)
' light=light+50
fill COLOR 0,0,light/255

'Draw Background of face (blue)

'triangle tx(f1),ty(f1) to tx(f2),ty(f2) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f2)
triy(1)=ty(f2)
trix(2)=tx(f3)
triy(2)=ty(f3)
fill poly trix, triy count 3
'gtriangle tx(f1),ty(f1) to tx(f4),ty(f4) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f4)
triy(1)=ty(f4)
trix(2)=tx(f3)
triy(2)=ty(f3)
fill poly trix, triy count 3

'Calculate Non Defined Co-Ordinates.
xt=(tx(f1)+tx(f2))/2 'Find Top Centre X
yt=(ty(f1)+ty(f2))/2 'Find Top Centre y
cx(1)=(xt+tx(f1))/2 'Calculate xpos 1
cy(1)=(yt+ty(f1))/2 'Calculate Ypos 1
cx(2)=(xt+tx(f2))/2 'Calculate xpos 2
cy(2)=(yt+ty(f2))/2 'Calculate Ypos 2
xt=(tx(f2)+tx(f3))/2 'Find side Centre X
yt=(ty(f2)+ty(f3))/2 'Find side Centre y
cx(3)=(xt+tx(f2))/2 'Calculate xpos 3
cy(3)=(yt+ty(f2))/2 'Calculate Ypos 3
cx(4)=(xt+tx(f3))/2 'Calculate xpos 4
cy(4)=(yt+ty(f3))/2 'Calculate Ypos 4
xt=(tx(f3)+tx(f4))/2 'Find bottom Centre X
yt=(ty(f3)+ty(f4))/2 'Find bottom Centre y
cx(5)=(xt+tx(f3))/2 'Calculate xpos 5
cy(5)=(yt+ty(f3))/2 'Calculate Ypos 5
cx(6)=(xt+tx(f4))/2 'Calculate xpos 6
cy(6)=(yt+ty(f4))/2 'Calculate Ypos 6
xt=(tx(f4)+tx(f1))/2 'Find side Centre X
yt=(ty(f4)+ty(f1))/2 'Find side Centre y
cx(7)=(xt+tx(f4))/2 'Calculate xpos 7
cy(7)=(yt+ty(f4))/2 'Calculate Ypos 7
cx(8)=(xt+tx(f1))/2 'Calculate xpos 8
cy(8)=(yt+ty(f1))/2 'Calculate Ypos 8
xt=(cx(1)+cx(6))/2 'Find side offset Centre 1
yt=(cy(1)+cy(6))/2 'Find side offset Centre 1
cx(9)=(xt+cx(1))/2 'Calculate xpos 9
cy(9)=(yt+cy(1))/2 'Calculate Ypos 9
cx(10)=(xt+cx(6))/2 'Calculate xpos 10
cy(10)=(yt+cy(6))/2 'Calculate Ypos 10
xt=(cx(2)+cx(5))/2 'Find side offset Centre 2
yt=(cy(2)+cy(5))/2 'Find side offset Centre 2
cx(11)=(xt+cx(2))/2 'Calculate xpos 11
cy(11)=(yt+cy(2))/2 'Calculate Ypos 11
cx(12)=(xt+cx(5))/2 'Calculate xpos 12
cy(12)=(yt+cy(5))/2 'Calculate Ypos 12

'Draw Red Polygons
fill COLOR .light,0,0
'triangle tx(f1),ty(f1) to cx(1),cy(1) to cx(9),cy(9)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(1)
triy(1)=cy(1)
trix(2)=cx(9)
triy(2)=cy(9)
fill poly trix, triy count 3
'gtriangle tx(f1),ty(f1) to cx(9),cy(9) to cx(8),cy(8)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(9)
triy(1)=cy(9)
trix(2)=cx(8)
triy(2)=cy(8)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(2),cy(2) to cx(11),cy(11)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(2)
triy(1)=cy(2)
trix(2)=cx(11)
triy(2)=cy(11)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(11),cy(11) to cx(3),cy(3)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(11)
triy(1)=cy(11)
trix(2)=cx(3)
triy(2)=cy(3)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(4),cy(4) to cx(12),cy(12)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(4)
triy(1)=cy(4)
trix(2)=cx(12)
triy(2)=cy(12)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(12),cy(12) to cx(5),cy(5)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(12)
triy(1)=cy(12)
trix(2)=cx(5)
triy(2)=cy(5)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(6),cy(6) to cx(10),cy(10)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(6)
triy(1)=cy(6)
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(10),cy(10) to cx(7),cy(7)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(10)
triy(1)=cy(10)
trix(2)=cx(7)
triy(2)=cy(7)
fill poly trix, triy count 3

' Draw The Green Polygons
fill COLOR 0,.light,0
'triangle cx(9),cy(9) to cx(10),cy(10) to cx(11),cy(11)
trix(0)=cx(9)
triy(0)=cy(9)
trix(1)=cx(10)
triy(1)=cy(10)
trix(2)=cx(11)
triy(2)=cy(11)
fill poly trix, triy count 3
'triangle cx(12),cy(12) to cx(11),cy(11) to cx(10),cy(10)
trix(0)=cx(12)
triy(0)=cy(12)
trix(1)=cx(11)
triy(1)=cy(11)
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3

'Draw Red Tron Lines
draw COLOR 1,0,0
draw LINE tx(f1),ty(f1) to tx(f2),ty(f2)
draw LINE tx(f2),ty(f2) to tx(f3),ty(f3)
draw LINE tx(f3),ty(f3) to tx(f4),ty(f4)
draw LINE tx(f4),ty(f4) to tx(f1),ty(f1)
draw LINE cx(1),cy(1) to cx(6),cy(6)
draw LINE cx(2),cy(2) to cx(5),cy(5)
draw LINE cx(3),cy(3) to cx(8),cy(8)
draw LINE cx(4),cy(4) to cx(7),cy(7)
END IF
RETURN

'Subroutine To Draw One Outer Face From 4 Passed Points
'This Wil Only Draw The Face If It Is In Front.

draw2:
' Calculate Poly Positions And Draw One Complete Face

'Hidden Line Removal Algorithm
'watch this will be in my writings
vx1= tx(f1)-tx(f2)
vy1= ty(f1)-ty(f2)
vx2= tx(f3)-tx(f2)
vy2= ty(f3)-ty(f2)
IF (vx1*vy2)-(vx2*vy1)<0 THEN

'Lightsource Color
light=-(tz(1)+tz(f2)+tz(f3)+tz(f4))*5
light=light+50
fill COLOR 0,0,.light

'Draw Background of face (blue)
'comment the shape yo see a cool efx!
'' fill triangle tx(f1),ty(f1) to tx(f2),ty(f2) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f2)
triy(1)=ty(f2)
trix(2)=tx(f3)
triy(2)=ty(f3)
'SHAPE 3, trix, triy
'comment the SHAPE to see a cool efx!
'' triangle tx(f1),ty(f1) to tx(f4),ty(f4) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f4)
triy(1)=ty(f4)
trix(2)=tx(f3)
triy(2)=ty(f3)
'SHAPE 3, trix, triy

'Calculate Non Defined Co-Ordinates.
xt=(tx(f1)+tx(f2))/2 'Find Top Centre X
yt=(ty(f1)+ty(f2))/2 'Find Top Centre y
cx(1)=(xt+tx(f1))/2 'Calculate xpos 1
cy(1)=(yt+ty(f1))/2 'Calculate Ypos 1
cx(2)=(xt+tx(f2))/2 'Calculate xpos 2
cy(2)=(yt+ty(f2))/2 'Calculate Ypos 2
xt=(tx(f2)+tx(f3))/2 'Find side Centre X
yt=(ty(f2)+ty(f3))/2 'Find side Centre y
cx(3)=(xt+tx(f2))/2 'Calculate xpos 3
cy(3)=(yt+ty(f2))/2 'Calculate Ypos 3
cx(4)=(xt+tx(f3))/2 'Calculate xpos 4
cy(4)=(yt+ty(f3))/2 'Calculate Ypos 4
xt=(tx(f3)+tx(f4))/2 'Find bottom Centre X
yt=(ty(f3)+ty(f4))/2 'Find bottom Centre y
cx(5)=(xt+tx(f3))/2 'Calculate xpos 5
cy(5)=(yt+ty(f3))/2 'Calculate Ypos 5
cx(6)=(xt+tx(f4))/2 'Calculate xpos 6
cy(6)=(yt+ty(f4))/2 'Calculate Ypos 6
xt=(tx(f4)+tx(f1))/2 'Find side Centre X
yt=(ty(f4)+ty(f1))/2 'Find side Centre y
cx(7)=(xt+tx(f4))/2 'Calculate xpos 7
cy(7)=(yt+ty(f4))/2 'Calculate Ypos 7
cx(8)=(xt+tx(f1))/2 'Calculate xpos 8
cy(8)=(yt+ty(f1))/2 'Calculate Ypos 8
xt=(cx(1)+cx(6))/2 'Find side offset Centre 1
yt=(cy(1)+cy(6))/2 'Find side offset Centre 1
cx(9)=(xt+cx(1))/2 'Calculate xpos 9
cy(9)=(yt+cy(1))/2 'Calculate Ypos 9
cx(10)=(xt+cx(6))/2 'Calculate xpos 10
cy(10)=(yt+cy(6))/2 'Calculate Ypos 10
xt=(cx(2)+cx(5))/2 'Find side offset Centre 2
yt=(cy(2)+cy(5))/2 'Find side offset Centre 2
cx(11)=(xt+cx(2))/2 'Calculate xpos 11
cy(11)=(yt+cy(2))/2 'Calculate Ypos 11
cx(12)=(xt+cx(5))/2 'Calculate xpos 12
cy(12)=(yt+cy(5))/2 'Calculate Ypos 12

'Draw Red Polygons
fill COLOR .light,0,0
'triangle tx(f1),ty(f1) to cx(1),cy(1) to cx(9),cy(9)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(1)
triy(1)=cy(1)
trix(2)=cx(9)
triy(2)=cy(9)
fill poly trix, triy count 3
'triangle tx(f1),ty(f1) to cx(9),cy(9) to cx(8),cy(8)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(9)
triy(1)=cy(9)
trix(2)=cx(8)
triy(2)=cy(8)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(2),cy(2) to cx(11),cy(11)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(2)
triy(1)=cy(2)
trix(2)=cx(11)
triy(2)=cy(11)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(11),cy(11) to cx(3),cy(3)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(11)
triy(1)=cy(11)
trix(2)=cx(3)
triy(2)=cy(3)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(4),cy(4) to cx(12),cy(12)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(4)
triy(1)=cy(4)
trix(2)=cx(12)
triy(2)=cy(12)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(12),cy(12) to cx(5),cy(5)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(12)
triy(1)=cy(12)
trix(2)=cx(5)
triy(2)=cy(5)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(6),cy(6) to cx(10),cy(10)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(6)
triy(1)=cy(6)
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(10),cy(10) to cx(7),cy(7)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(10)
triy(1)=cy(10)
trix(2)=cx(7)
triy(2)=cy(7)
fill poly trix, triy count 3

'Draw The Green Polygons
fill COLOR 0,.light,0
'triangle cx(9),cy(9) to cx(11),cy(11) to cx(10),cy(10)
trix(0)=cx(9)
triy(0)=cy(9)
trix(1)=cx(11)
triy(1)=cy(11)
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3
'triangle cx(12),cy(12) to cx(11),cy(11) to cx(10),cy(10)
trix(0)=cx(12)
triy(0)=cy(12)
trix(1)=cx(11)
triy(1)=cy(11)
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3

'Black Lines
draw COLOR 40,110,150
draw LINE tx(f1),ty(f1) to tx(f2),ty(f2)
draw LINE tx(f2),ty(f2) to tx(f3),ty(f3)
draw LINE tx(f3),ty(f3) to tx(f4),ty(f4)
draw LINE tx(f4),ty(f4) to tx(f1),ty(f1)
draw LINE cx(1),cy(1) to cx(6),cy(6)
draw LINE cx(2),cy(2) to cx(5),cy(5)
draw LINE cx(3),cy(3) to cx(8),cy(8)
draw LINE cx(4),cy(4) to cx(7),cy(7)
END IF

RETURN

'This Subroutine Rotates The Eight Corner Points About
'Thier X,Y and Z Axis Using Matrices And Applys A
'Perspective Formula To The Transformed Points.
'All Logical Points are derived from these 8.

rotate:

'Rotate And Scale Each Point - Store Result
FOR a=1 TO polys
x1=x(a)
y1=y(a)
z1=z(a)

'X,Y,Z rotations!
xx=x1
yy=y1*cs(xr)+z1*sn(xr)
zz=z1*cs(xr)-y1*sn(xr)
y1=yy
x1=xx*cs(yr)-zz*sn(yr)
z1=xx*sn(yr)+zz*cs(yr)
zz=z1
xx=x1*cs(zr)-y1*sn(zr)
yy=x1*sn(zr)+y1*cs(zr)

'Apply Perspective!
xx=size*(xx/((zz/50)+1))+sw/2
yy=size*(yy/((zz/50)+1))+sh/2
tx(a)=xx
ty(a)=yy
tz(a)=zz
NEXT a

' Incriment Rotations!
xr=xr+3
yr=yr+2
zr=zr+1
IF xr>720 THEN
xr=xr-720
END IF
IF yr>720 THEN
yr=yr-720
END IF
IF zr>720 THEN
zr=zr-720
END IF
RETURN

initialize:
sw=Screen_Width()
sh=Screen_Height()
csw=sw/2
csh=sh/2
pi = 3.1415
' This Sub-Routine Initializes The Program.

'Scroll Variables
s$=" "
s$=s$&"CAN YOU GUESS WHY THIS IS CALLED THE ACETAMINOPHEN"
s$=s$&"??? NO??? WELL WATCH IT FOR HALF AN HOUR "
s$=s$&"AND YOU'LL FIND OUT THE HARD WAY.... GUARANTEED"
s$=s$&" TO CAUSE A BLINDING HEADACHE... I TRIED TO MAKE "
s$=s$&"SOMETHING COLORFUL. "
p=0
scx=0


' Writer Variables
messages=16 ' How Many text lines?
mc=1
DIM m$(messages+2) 'Set Space For Them
FOR a=1 TO messages 'Read Them In
READ m$(a)
NEXT a

'Define the necessary variables!
size=12 'how big do you want it?
polys=8 'The amount of vertices in the object
DIM x(polys+1) 'Original X co-ordinate store
DIM y(polys+1) 'Original Y co-ordinate store
DIM z(polys+1) 'Original Z co-ordinate store
DIM tx(polys+1) 'Transformed X co-ordinate store
DIM ty(polys+1) 'Transformed Y co-ordinate store
DIM tz(polys+1) 'Transformed Z co-ordinate store
DIM cx(13) ' Storage For Calculated X
DIM cy(13) ' Storage For Calculated Y
DIM trix(4),triy(4) ' triangle

xr=3
yr=2
zr=1

'Define Sine Tables!!
DIM cs(722)
DIM sn(722)
FOR ang=0 TO 720
cs(ang)=COS(ang*(PI/360))
sn(ang)=SIN(ang*(PI/360))
NEXT ang

' Read in the object!
FOR a=1 TO polys
READ x(a),y(a),z(a)
NEXT a

text:
DATA "WELCOME TO","ACETAMINOPHEN"
DATA "BASIC RULES!","3D MANIPULATION"
DATA "MULTI MESSAGES","PRECALCULATED MATH"
DATA "HIDDEN LINES","3D ROTATIONS"
DATA "TRON COLORS!","AWESOME BASIC"
DATA "HI TO:","DUTCHMAN"
DATA "OPERATOR","MY SON DIGIT"
DATA "MR K.","FORUM MEMBERS!"

' The Object Description As Data!
' The Data Below Describes A Cube.
obj:
DATA -10,10,10,10,10,10,10,-10,10,-10,-10,10
DATA -10,10,-10,10,10,-10,10,-10,-10,-10,-10,-10
RETURN

[Mr. Kibernetik]

Looks cool!
Well, I made it more colorful:

Code: Select all

REM ACETAMINOPHEN 
REM You'll need some afterwards
REM iPhone 6 plus
REM enjoy 
REM the shapes in the blue 
REM to get a cool effect!! 
notes stop
notes load "/Examples/10. Music & Sound/files/test5.mid"
notes play

graphics
'Program Notes: This demo started life as a wire frame
'3D routine that I developed to model a simple 3D cube....
'My previous 3D had depth sorted faces, this one uses a
'hidden line algorithm that checks if the points of a given 
'face are in clockwise or 
'anticlockwise order to see if they should 
'be drawn.... I Added some light sourcing
'to the cube, and borrowed an idea from 
'my other demos.

'Set Everything up
GOSUB initialize 

dgc=0.01
dgcr=dgc!dgcg=dgc!dgcb=dgc
gcr=0!gcg=.5!gcb=1

' Main Loop
loop:
refresh off
'Draw Backround
gcr+=dgcr!gcg+=dgcg!gcb+=dgcb
if gcr>1 or gcr<0 then dgcr=-dgcr
if gcg>1 or gcg<0 then dgcg=-dgcg
if gcb>1 or gcb<0 then dgcb=-dgcb
graphics clear gcr,gcg,gcb

'Call Rotation Routine
GOSUB rotate 

'Draw Inside Faces
'Color 10,30,10
f1=1 
f2=2 
f3=3 
f4=4 'Face 1
GOSUB draw 'Draw Face 1
f1=5 
f2=8 
f3=7 
f4=6 'Face 2
GOSUB draw 'Draw Face 2
f1=6 
f2=2 
f3=1 
f4=5 'Face 3
GOSUB draw 'Draw Face 3
f1=8 
f2=4 
f3=3 
f4=7 ' Face 4
GOSUB draw 'Draw Face 4
f1=2 
f2=6 
f3=7 
f4=3 'Face 5
GOSUB draw 'Draw Face 5
f1=8 
f2=5 
f3=1 
f4=4 'Face 6
GOSUB draw 'Draw Face 6

' Draw Outside Faces
f1=1 
f2=2 
f3=3 
f4=4 'Face 1
GOSUB draw2 'Draw Face 1
f1=5 
f2=8 
f3=7 
f4=6 'Face 2
GOSUB draw2 'Draw Face 2
f1=6 
f2=2 
f3=1 
f4=5 'Face 3
GOSUB draw2 'Draw Face 3
f1=8 
f2=4 
f3=3 
f4=7 'Face 4
GOSUB draw2 'Draw Face 4
f1=2 
f2=6 
f3=7 
f4=3 'Face 5
GOSUB draw2 'Draw Face 5
f1=8 
f2=5 
f3=1 
f4=4 'Face 6
GOSUB draw2 'Draw Face 6

'Display Text
stext$=substr$(s$,p,len(s$)-1)
draw COLOR 0,0,0
DRAW TEXT "ACETAMINOPHEN" at 0,2
DRAW TEXT stext$ at scx+2,sch-18
draw COLOR 1,1,1
DRAW TEXT "ACETAMINOPHEN" at 0,0
'DRAW TEXT stext$ at scx,sch-20

'Scroller Code


ls=len(s$)-1
text$=substr$(s$,p,ls)
draw color 0,0,0
draw text text$ at scx+2,sh-18
draw color 1,1,1
draw text text$ at scx,sh-20


'draw text substr$(s$,p,ls) at scx,texty
scx-=1
if scx<-50 then
scx+=10
p+=1
if p>ls then p=1
end if


GOSUB writer
refresh on
GOTO loop
'Main Loop Ends

'Subroutines

'This Subroutine Does The Bouncy Greetings Thing;

writer:
mm=mm+.05
IF mm>4 THEN
mm=0
mc=mc+1
IF mc>messages THEN
mc=1
END IF 
END IF
draw COLOR 1,1,1
DRAW TEXT m$(mc) at csw-LEN(m$(mc))*5,70*SIN(mm)
RETURN

'Subroutine To Draw One Inner Face From 4 Passed Points
'This Will Only Draw The Face If It Is Behind.

draw:
'Calculate Poly Positions And Draw One Complete Face

'Hidden Line Removal Algorithm
vx1= tx(f1)-tx(f2)
vy1= ty(f1)-ty(f2)
vx2= tx(f3)-tx(f2)
vy2= ty(f3)-ty(f2)
IF (vx1*vy2)-(vx2*vy1)>0 THEN

'Lightsource Color
light=(tz(1)+tz(f2)+tz(f3)+tz(f4)*3)
' light=light+50
fill COLOR 0,0,light/255

'Draw Background of face (blue)

'triangle tx(f1),ty(f1) to tx(f2),ty(f2) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f2)
triy(1)=ty(f2) 
trix(2)=tx(f3)
triy(2)=ty(f3)
fill poly trix, triy count 3
'gtriangle tx(f1),ty(f1) to tx(f4),ty(f4) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f4)
triy(1)=ty(f4) 
trix(2)=tx(f3)
triy(2)=ty(f3)
fill poly trix, triy count 3

'Calculate Non Defined Co-Ordinates.
xt=(tx(f1)+tx(f2))/2 'Find Top Centre X
yt=(ty(f1)+ty(f2))/2 'Find Top Centre y
cx(1)=(xt+tx(f1))/2 'Calculate xpos 1
cy(1)=(yt+ty(f1))/2 'Calculate Ypos 1
cx(2)=(xt+tx(f2))/2 'Calculate xpos 2 
cy(2)=(yt+ty(f2))/2 'Calculate Ypos 2
xt=(tx(f2)+tx(f3))/2 'Find side Centre X
yt=(ty(f2)+ty(f3))/2 'Find side Centre y
cx(3)=(xt+tx(f2))/2 'Calculate xpos 3
cy(3)=(yt+ty(f2))/2 'Calculate Ypos 3
cx(4)=(xt+tx(f3))/2 'Calculate xpos 4
cy(4)=(yt+ty(f3))/2 'Calculate Ypos 4
xt=(tx(f3)+tx(f4))/2 'Find bottom Centre X
yt=(ty(f3)+ty(f4))/2 'Find bottom Centre y
cx(5)=(xt+tx(f3))/2 'Calculate xpos 5
cy(5)=(yt+ty(f3))/2 'Calculate Ypos 5
cx(6)=(xt+tx(f4))/2 'Calculate xpos 6
cy(6)=(yt+ty(f4))/2 'Calculate Ypos 6
xt=(tx(f4)+tx(f1))/2 'Find side Centre X
yt=(ty(f4)+ty(f1))/2 'Find side Centre y
cx(7)=(xt+tx(f4))/2 'Calculate xpos 7
cy(7)=(yt+ty(f4))/2 'Calculate Ypos 7
cx(8)=(xt+tx(f1))/2 'Calculate xpos 8
cy(8)=(yt+ty(f1))/2 'Calculate Ypos 8
xt=(cx(1)+cx(6))/2 'Find side offset Centre 1
yt=(cy(1)+cy(6))/2 'Find side offset Centre 1
cx(9)=(xt+cx(1))/2 'Calculate xpos 9
cy(9)=(yt+cy(1))/2 'Calculate Ypos 9
cx(10)=(xt+cx(6))/2 'Calculate xpos 10
cy(10)=(yt+cy(6))/2 'Calculate Ypos 10
xt=(cx(2)+cx(5))/2 'Find side offset Centre 2
yt=(cy(2)+cy(5))/2 'Find side offset Centre 2
cx(11)=(xt+cx(2))/2 'Calculate xpos 11
cy(11)=(yt+cy(2))/2 'Calculate Ypos 11
cx(12)=(xt+cx(5))/2 'Calculate xpos 12
cy(12)=(yt+cy(5))/2 'Calculate Ypos 12

'Draw Red Polygons
fill COLOR .light,0,0
'triangle tx(f1),ty(f1) to cx(1),cy(1) to cx(9),cy(9)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(1)
triy(1)=cy(1) 
trix(2)=cx(9)
triy(2)=cy(9)
fill poly trix, triy count 3
'gtriangle tx(f1),ty(f1) to cx(9),cy(9) to cx(8),cy(8)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(9)
triy(1)=cy(9) 
trix(2)=cx(8)
triy(2)=cy(8)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(2),cy(2) to cx(11),cy(11)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(2)
triy(1)=cy(2) 
trix(2)=cx(11)
triy(2)=cy(11)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(11),cy(11) to cx(3),cy(3)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(11)
triy(1)=cy(11) 
trix(2)=cx(3)
triy(2)=cy(3)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(4),cy(4) to cx(12),cy(12)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(4)
triy(1)=cy(4) 
trix(2)=cx(12)
triy(2)=cy(12)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(12),cy(12) to cx(5),cy(5)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(12)
triy(1)=cy(12) 
trix(2)=cx(5)
triy(2)=cy(5)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(6),cy(6) to cx(10),cy(10)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(6)
triy(1)=cy(6) 
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(10),cy(10) to cx(7),cy(7)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(10)
triy(1)=cy(10) 
trix(2)=cx(7)
triy(2)=cy(7)
fill poly trix, triy count 3

' Draw The Green Polygons
fill COLOR 0,.light,0
'triangle cx(9),cy(9) to cx(10),cy(10) to cx(11),cy(11)
trix(0)=cx(9)
triy(0)=cy(9)
trix(1)=cx(10)
triy(1)=cy(10) 
trix(2)=cx(11)
triy(2)=cy(11)
fill poly trix, triy count 3
'triangle cx(12),cy(12) to cx(11),cy(11) to cx(10),cy(10)
trix(0)=cx(12)
triy(0)=cy(12)
trix(1)=cx(11)
triy(1)=cy(11) 
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3

'Draw Red Tron Lines
draw COLOR 1,0,0
draw LINE tx(f1),ty(f1) to tx(f2),ty(f2)
draw LINE tx(f2),ty(f2) to tx(f3),ty(f3)
draw LINE tx(f3),ty(f3) to tx(f4),ty(f4)
draw LINE tx(f4),ty(f4) to tx(f1),ty(f1)
draw LINE cx(1),cy(1) to cx(6),cy(6)
draw LINE cx(2),cy(2) to cx(5),cy(5)
draw LINE cx(3),cy(3) to cx(8),cy(8)
draw LINE cx(4),cy(4) to cx(7),cy(7)
END IF
RETURN

'Subroutine To Draw One Outer Face From 4 Passed Points
'This Wil Only Draw The Face If It Is In Front.

draw2:
' Calculate Poly Positions And Draw One Complete Face

'Hidden Line Removal Algorithm
'watch this will be in my writings
vx1= tx(f1)-tx(f2)
vy1= ty(f1)-ty(f2)
vx2= tx(f3)-tx(f2)
vy2= ty(f3)-ty(f2)
IF (vx1*vy2)-(vx2*vy1)<0 THEN

'Lightsource Color
light=-(tz(1)+tz(f2)+tz(f3)+tz(f4))*5
light=light+50
fill COLOR 0,0,.light

'Draw Background of face (blue)
'comment the shape yo see a cool efx! 
'' fill triangle tx(f1),ty(f1) to tx(f2),ty(f2) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f2)
triy(1)=ty(f2) 
trix(2)=tx(f3)
triy(2)=ty(f3)
'SHAPE 3, trix, triy
'comment the SHAPE to see a cool efx!
'' triangle tx(f1),ty(f1) to tx(f4),ty(f4) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f4)
triy(1)=ty(f4) 
trix(2)=tx(f3)
triy(2)=ty(f3)
'SHAPE 3, trix, triy

'Calculate Non Defined Co-Ordinates.
xt=(tx(f1)+tx(f2))/2 'Find Top Centre X
yt=(ty(f1)+ty(f2))/2 'Find Top Centre y
cx(1)=(xt+tx(f1))/2 'Calculate xpos 1
cy(1)=(yt+ty(f1))/2 'Calculate Ypos 1
cx(2)=(xt+tx(f2))/2 'Calculate xpos 2 
cy(2)=(yt+ty(f2))/2 'Calculate Ypos 2
xt=(tx(f2)+tx(f3))/2 'Find side Centre X
yt=(ty(f2)+ty(f3))/2 'Find side Centre y
cx(3)=(xt+tx(f2))/2 'Calculate xpos 3
cy(3)=(yt+ty(f2))/2 'Calculate Ypos 3
cx(4)=(xt+tx(f3))/2 'Calculate xpos 4
cy(4)=(yt+ty(f3))/2 'Calculate Ypos 4
xt=(tx(f3)+tx(f4))/2 'Find bottom Centre X
yt=(ty(f3)+ty(f4))/2 'Find bottom Centre y
cx(5)=(xt+tx(f3))/2 'Calculate xpos 5
cy(5)=(yt+ty(f3))/2 'Calculate Ypos 5
cx(6)=(xt+tx(f4))/2 'Calculate xpos 6
cy(6)=(yt+ty(f4))/2 'Calculate Ypos 6
xt=(tx(f4)+tx(f1))/2 'Find side Centre X
yt=(ty(f4)+ty(f1))/2 'Find side Centre y
cx(7)=(xt+tx(f4))/2 'Calculate xpos 7
cy(7)=(yt+ty(f4))/2 'Calculate Ypos 7
cx(8)=(xt+tx(f1))/2 'Calculate xpos 8
cy(8)=(yt+ty(f1))/2 'Calculate Ypos 8
xt=(cx(1)+cx(6))/2 'Find side offset Centre 1
yt=(cy(1)+cy(6))/2 'Find side offset Centre 1
cx(9)=(xt+cx(1))/2 'Calculate xpos 9
cy(9)=(yt+cy(1))/2 'Calculate Ypos 9
cx(10)=(xt+cx(6))/2 'Calculate xpos 10
cy(10)=(yt+cy(6))/2 'Calculate Ypos 10
xt=(cx(2)+cx(5))/2 'Find side offset Centre 2
yt=(cy(2)+cy(5))/2 'Find side offset Centre 2
cx(11)=(xt+cx(2))/2 'Calculate xpos 11
cy(11)=(yt+cy(2))/2 'Calculate Ypos 11
cx(12)=(xt+cx(5))/2 'Calculate xpos 12
cy(12)=(yt+cy(5))/2 'Calculate Ypos 12

'Draw Red Polygons
fill COLOR .light,0,0
'triangle tx(f1),ty(f1) to cx(1),cy(1) to cx(9),cy(9)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(1)
triy(1)=cy(1) 
trix(2)=cx(9)
triy(2)=cy(9)
fill poly trix, triy count 3
'triangle tx(f1),ty(f1) to cx(9),cy(9) to cx(8),cy(8)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(9)
triy(1)=cy(9) 
trix(2)=cx(8)
triy(2)=cy(8)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(2),cy(2) to cx(11),cy(11)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(2)
triy(1)=cy(2) 
trix(2)=cx(11)
triy(2)=cy(11)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(11),cy(11) to cx(3),cy(3)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(11)
triy(1)=cy(11) 
trix(2)=cx(3)
triy(2)=cy(3)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(4),cy(4) to cx(12),cy(12)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(4)
triy(1)=cy(4) 
trix(2)=cx(12)
triy(2)=cy(12)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(12),cy(12) to cx(5),cy(5)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(12)
triy(1)=cy(12) 
trix(2)=cx(5)
triy(2)=cy(5)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(6),cy(6) to cx(10),cy(10)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(6)
triy(1)=cy(6) 
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(10),cy(10) to cx(7),cy(7)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(10)
triy(1)=cy(10) 
trix(2)=cx(7)
triy(2)=cy(7)
fill poly trix, triy count 3

'Draw The Green Polygons
fill COLOR 0,.light,0
'triangle cx(9),cy(9) to cx(11),cy(11) to cx(10),cy(10)
trix(0)=cx(9)
triy(0)=cy(9)
trix(1)=cx(11)
triy(1)=cy(11) 
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3
'triangle cx(12),cy(12) to cx(11),cy(11) to cx(10),cy(10)
trix(0)=cx(12)
triy(0)=cy(12)
trix(1)=cx(11)
triy(1)=cy(11) 
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3

'Black Lines
draw COLOR 40,110,150
draw LINE tx(f1),ty(f1) to tx(f2),ty(f2)
draw LINE tx(f2),ty(f2) to tx(f3),ty(f3)
draw LINE tx(f3),ty(f3) to tx(f4),ty(f4)
draw LINE tx(f4),ty(f4) to tx(f1),ty(f1)
draw LINE cx(1),cy(1) to cx(6),cy(6)
draw LINE cx(2),cy(2) to cx(5),cy(5)
draw LINE cx(3),cy(3) to cx(8),cy(8)
draw LINE cx(4),cy(4) to cx(7),cy(7)
END IF

RETURN

'This Subroutine Rotates The Eight Corner Points About
'Thier X,Y and Z Axis Using Matrices And Applys A
'Perspective Formula To The Transformed Points.
'All Logical Points are derived from these 8.

rotate:

'Rotate And Scale Each Point - Store Result 
FOR a=1 TO polys
x1=x(a)
y1=y(a)
z1=z(a)

'X,Y,Z rotations! 
xx=x1
yy=y1*cs(xr)+z1*sn(xr)
zz=z1*cs(xr)-y1*sn(xr)
y1=yy
x1=xx*cs(yr)-zz*sn(yr)
z1=xx*sn(yr)+zz*cs(yr)
zz=z1
xx=x1*cs(zr)-y1*sn(zr)
yy=x1*sn(zr)+y1*cs(zr)

'Apply Perspective! 
xx=size*(xx/((zz/50)+1))+sw/2
yy=size*(yy/((zz/50)+1))+sh/2 
tx(a)=xx
ty(a)=yy
tz(a)=zz
NEXT a

' Incriment Rotations! 
xr=xr+3
yr=yr+2
zr=zr+1
IF xr>720 THEN
xr=xr-720
END IF
IF yr>720 THEN
yr=yr-720
END IF
IF zr>720 THEN
zr=zr-720
END IF
RETURN

initialize:
sw=Screen_Width()
sh=Screen_Height()
csw=sw/2
csh=sh/2
pi = 3.1415
' This Sub-Routine Initializes The Program.

'Scroll Variables
s$=" "
s$=s$&"CAN YOU GUESS WHY THIS IS CALLED THE ACETAMINOPHEN"
s$=s$&"??? NO??? WELL WATCH IT FOR HALF AN HOUR "
s$=s$&"AND YOU'LL FIND OUT THE HARD WAY.... GUARANTEED"
s$=s$&" TO CAUSE A BLINDING HEADACHE... I TRIED TO MAKE "
s$=s$&"SOMETHING COLORFUL. "
p=0
scx=0


' Writer Variables
messages=17 ' How Many text lines?
mc=1
DIM m$(messages+2) 'Set Space For Them
FOR a=1 TO messages 'Read Them In
READ m$(a)
NEXT a

'Define the necessary variables! 
size=12 'how big do you want it?
polys=8 'The amount of vertices in the object
DIM x(polys+1) 'Original X co-ordinate store
DIM y(polys+1) 'Original Y co-ordinate store
DIM z(polys+1) 'Original Z co-ordinate store
DIM tx(polys+1) 'Transformed X co-ordinate store
DIM ty(polys+1) 'Transformed Y co-ordinate store
DIM tz(polys+1) 'Transformed Z co-ordinate store
DIM cx(13) ' Storage For Calculated X
DIM cy(13) ' Storage For Calculated Y
DIM trix(4),triy(4) ' triangle 

xr=3
yr=2
zr=1

'Define Sine Tables!! 
DIM cs(722)
DIM sn(722)
FOR ang=0 TO 720
cs(ang)=COS(ang*(PI/360))
sn(ang)=SIN(ang*(PI/360))
NEXT ang

' Read in the object! 
FOR a=1 TO polys
READ x(a),y(a),z(a)
NEXT a

text: 
DATA "WELCOME TO","ACETAMINOPHEN"
DATA "BASIC RULES!","3D MANIPULATION"
DATA "MULTI MESSAGES","PRECALCULATED MATH"
DATA "HIDDEN LINES","3D ROTATIONS"
DATA "TRON COLORS!","AWESOME BASIC"
DATA "HI TO:","DUTCHMAN"
DATA "OPERATOR","DIGIT"
DATA "MR K.","DR CHIP","FORUM MEMBERS!"

' The Object Description As Data!
' The Data Below Describes A Cube.
obj:
DATA -10,10,10,10,10,10,10,-10,10,-10,-10,10
DATA -10,10,-10,10,10,-10,10,-10,-10,-10,-10,-10
RETURN

[Mr. Kibernetik]

Also you can add
OPTION SCREENLOCK OFF
to disable screen locking while playing.

[DrChip]

Nice! Thanks!

[Mr. Kibernetik]

Ok, I corrected a bug in my background and now it is as colorful as it should be. Also music should play eternally.

Code: Select all

REM ACETAMINOPHEN 
REM You'll need some afterwards
REM iPhone 6 plus
REM enjoy 
REM the shapes in the blue 
REM to get a cool effect!! 

def reload
notes load "/Examples/10. Music & Sound/files/test5.mid"
notes play
enddef

reload

graphics
'Program Notes: This demo started life as a wire frame
'3D routine that I developed to model a simple 3D cube....
'My previous 3D had depth sorted faces, this one uses a
'hidden line algorithm that checks if the points of a given 
'face are in clockwise or 
'anticlockwise order to see if they should 
'be drawn.... I Added some light sourcing
'to the cube, and borrowed an idea from 
'my other demos.

'Set Everything up
GOSUB initialize
refresh off

option screenlock off
dgc=0.01
dgcr=dgc!dgcg=dgc!dgcb=dgc
gcr=0!gcg=.33!gcb=.66

' Main Loop
loop:
if notes_time()>notes_length() then reload
'Draw Backround
gcr+=dgcr!gcg+=dgcg!gcb+=dgcb
if gcr>1 or gcr<0 then dgcr=-dgcr
if gcg>1 or gcg<0 then dgcg=-dgcg
if gcb>1 or gcb<0 then dgcb=-dgcb
graphics clear gcr,gcg,gcb

'Call Rotation Routine
GOSUB rotate 

'Draw Inside Faces
'Color 10,30,10
f1=1 
f2=2 
f3=3 
f4=4 'Face 1
GOSUB draw 'Draw Face 1
f1=5 
f2=8 
f3=7 
f4=6 'Face 2
GOSUB draw 'Draw Face 2
f1=6 
f2=2 
f3=1 
f4=5 'Face 3
GOSUB draw 'Draw Face 3
f1=8 
f2=4 
f3=3 
f4=7 ' Face 4
GOSUB draw 'Draw Face 4
f1=2 
f2=6 
f3=7 
f4=3 'Face 5
GOSUB draw 'Draw Face 5
f1=8 
f2=5 
f3=1 
f4=4 'Face 6
GOSUB draw 'Draw Face 6

' Draw Outside Faces
f1=1 
f2=2 
f3=3 
f4=4 'Face 1
GOSUB draw2 'Draw Face 1
f1=5 
f2=8 
f3=7 
f4=6 'Face 2
GOSUB draw2 'Draw Face 2
f1=6 
f2=2 
f3=1 
f4=5 'Face 3
GOSUB draw2 'Draw Face 3
f1=8 
f2=4 
f3=3 
f4=7 'Face 4
GOSUB draw2 'Draw Face 4
f1=2 
f2=6 
f3=7 
f4=3 'Face 5
GOSUB draw2 'Draw Face 5
f1=8 
f2=5 
f3=1 
f4=4 'Face 6
GOSUB draw2 'Draw Face 6

'Display Text
stext$=substr$(s$,p,len(s$)-1)
draw COLOR 0,0,0
DRAW TEXT "ACETAMINOPHEN" at 0,2
DRAW TEXT stext$ at scx+2,sch-18
draw COLOR 1,1,1
DRAW TEXT "ACETAMINOPHEN" at 0,0
'DRAW TEXT stext$ at scx,sch-20

'Scroller Code


ls=len(s$)-1
text$=substr$(s$,p,ls)
draw color 0,0,0
draw text text$ at scx+2,sh-18
draw color 1,1,1
draw text text$ at scx,sh-20


'draw text substr$(s$,p,ls) at scx,texty
scx-=1
if scx<-50 then
scx+=10
p+=1
if p>ls then p=1
end if


GOSUB writer
refresh
GOTO loop
'Main Loop Ends

'Subroutines

'This Subroutine Does The Bouncy Greetings Thing;

writer:
mm=mm+.05
IF mm>4 THEN
mm=0
mc=mc+1
IF mc>messages THEN
mc=1
END IF 
END IF
draw COLOR 1,1,1
DRAW TEXT m$(mc) at csw-LEN(m$(mc))*5,70*SIN(mm)
RETURN

'Subroutine To Draw One Inner Face From 4 Passed Points
'This Will Only Draw The Face If It Is Behind.

draw:
'Calculate Poly Positions And Draw One Complete Face

'Hidden Line Removal Algorithm
vx1= tx(f1)-tx(f2)
vy1= ty(f1)-ty(f2)
vx2= tx(f3)-tx(f2)
vy2= ty(f3)-ty(f2)
IF (vx1*vy2)-(vx2*vy1)>0 THEN

'Lightsource Color
light=(tz(1)+tz(f2)+tz(f3)+tz(f4)*3)
' light=light+50
fill COLOR 0,0,light/255

'Draw Background of face (blue)

'triangle tx(f1),ty(f1) to tx(f2),ty(f2) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f2)
triy(1)=ty(f2) 
trix(2)=tx(f3)
triy(2)=ty(f3)
fill poly trix, triy count 3
'gtriangle tx(f1),ty(f1) to tx(f4),ty(f4) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f4)
triy(1)=ty(f4) 
trix(2)=tx(f3)
triy(2)=ty(f3)
fill poly trix, triy count 3

'Calculate Non Defined Co-Ordinates.
xt=(tx(f1)+tx(f2))/2 'Find Top Centre X
yt=(ty(f1)+ty(f2))/2 'Find Top Centre y
cx(1)=(xt+tx(f1))/2 'Calculate xpos 1
cy(1)=(yt+ty(f1))/2 'Calculate Ypos 1
cx(2)=(xt+tx(f2))/2 'Calculate xpos 2 
cy(2)=(yt+ty(f2))/2 'Calculate Ypos 2
xt=(tx(f2)+tx(f3))/2 'Find side Centre X
yt=(ty(f2)+ty(f3))/2 'Find side Centre y
cx(3)=(xt+tx(f2))/2 'Calculate xpos 3
cy(3)=(yt+ty(f2))/2 'Calculate Ypos 3
cx(4)=(xt+tx(f3))/2 'Calculate xpos 4
cy(4)=(yt+ty(f3))/2 'Calculate Ypos 4
xt=(tx(f3)+tx(f4))/2 'Find bottom Centre X
yt=(ty(f3)+ty(f4))/2 'Find bottom Centre y
cx(5)=(xt+tx(f3))/2 'Calculate xpos 5
cy(5)=(yt+ty(f3))/2 'Calculate Ypos 5
cx(6)=(xt+tx(f4))/2 'Calculate xpos 6
cy(6)=(yt+ty(f4))/2 'Calculate Ypos 6
xt=(tx(f4)+tx(f1))/2 'Find side Centre X
yt=(ty(f4)+ty(f1))/2 'Find side Centre y
cx(7)=(xt+tx(f4))/2 'Calculate xpos 7
cy(7)=(yt+ty(f4))/2 'Calculate Ypos 7
cx(8)=(xt+tx(f1))/2 'Calculate xpos 8
cy(8)=(yt+ty(f1))/2 'Calculate Ypos 8
xt=(cx(1)+cx(6))/2 'Find side offset Centre 1
yt=(cy(1)+cy(6))/2 'Find side offset Centre 1
cx(9)=(xt+cx(1))/2 'Calculate xpos 9
cy(9)=(yt+cy(1))/2 'Calculate Ypos 9
cx(10)=(xt+cx(6))/2 'Calculate xpos 10
cy(10)=(yt+cy(6))/2 'Calculate Ypos 10
xt=(cx(2)+cx(5))/2 'Find side offset Centre 2
yt=(cy(2)+cy(5))/2 'Find side offset Centre 2
cx(11)=(xt+cx(2))/2 'Calculate xpos 11
cy(11)=(yt+cy(2))/2 'Calculate Ypos 11
cx(12)=(xt+cx(5))/2 'Calculate xpos 12
cy(12)=(yt+cy(5))/2 'Calculate Ypos 12

'Draw Red Polygons
fill COLOR .light,0,0
'triangle tx(f1),ty(f1) to cx(1),cy(1) to cx(9),cy(9)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(1)
triy(1)=cy(1) 
trix(2)=cx(9)
triy(2)=cy(9)
fill poly trix, triy count 3
'gtriangle tx(f1),ty(f1) to cx(9),cy(9) to cx(8),cy(8)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(9)
triy(1)=cy(9) 
trix(2)=cx(8)
triy(2)=cy(8)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(2),cy(2) to cx(11),cy(11)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(2)
triy(1)=cy(2) 
trix(2)=cx(11)
triy(2)=cy(11)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(11),cy(11) to cx(3),cy(3)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(11)
triy(1)=cy(11) 
trix(2)=cx(3)
triy(2)=cy(3)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(4),cy(4) to cx(12),cy(12)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(4)
triy(1)=cy(4) 
trix(2)=cx(12)
triy(2)=cy(12)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(12),cy(12) to cx(5),cy(5)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(12)
triy(1)=cy(12) 
trix(2)=cx(5)
triy(2)=cy(5)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(6),cy(6) to cx(10),cy(10)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(6)
triy(1)=cy(6) 
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(10),cy(10) to cx(7),cy(7)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(10)
triy(1)=cy(10) 
trix(2)=cx(7)
triy(2)=cy(7)
fill poly trix, triy count 3

' Draw The Green Polygons
fill COLOR 0,.light,0
'triangle cx(9),cy(9) to cx(10),cy(10) to cx(11),cy(11)
trix(0)=cx(9)
triy(0)=cy(9)
trix(1)=cx(10)
triy(1)=cy(10) 
trix(2)=cx(11)
triy(2)=cy(11)
fill poly trix, triy count 3
'triangle cx(12),cy(12) to cx(11),cy(11) to cx(10),cy(10)
trix(0)=cx(12)
triy(0)=cy(12)
trix(1)=cx(11)
triy(1)=cy(11) 
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3

'Draw Red Tron Lines
draw COLOR 1,0,0
draw LINE tx(f1),ty(f1) to tx(f2),ty(f2)
draw LINE tx(f2),ty(f2) to tx(f3),ty(f3)
draw LINE tx(f3),ty(f3) to tx(f4),ty(f4)
draw LINE tx(f4),ty(f4) to tx(f1),ty(f1)
draw LINE cx(1),cy(1) to cx(6),cy(6)
draw LINE cx(2),cy(2) to cx(5),cy(5)
draw LINE cx(3),cy(3) to cx(8),cy(8)
draw LINE cx(4),cy(4) to cx(7),cy(7)
END IF
RETURN

'Subroutine To Draw One Outer Face From 4 Passed Points
'This Wil Only Draw The Face If It Is In Front.

draw2:
' Calculate Poly Positions And Draw One Complete Face

'Hidden Line Removal Algorithm
'watch this will be in my writings
vx1= tx(f1)-tx(f2)
vy1= ty(f1)-ty(f2)
vx2= tx(f3)-tx(f2)
vy2= ty(f3)-ty(f2)
IF (vx1*vy2)-(vx2*vy1)<0 THEN

'Lightsource Color
light=-(tz(1)+tz(f2)+tz(f3)+tz(f4))*5
light=light+50
fill COLOR 0,0,.light

'Draw Background of face (blue)
'comment the shape yo see a cool efx! 
'' fill triangle tx(f1),ty(f1) to tx(f2),ty(f2) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f2)
triy(1)=ty(f2) 
trix(2)=tx(f3)
triy(2)=ty(f3)
'SHAPE 3, trix, triy
'comment the SHAPE to see a cool efx!
'' triangle tx(f1),ty(f1) to tx(f4),ty(f4) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f4)
triy(1)=ty(f4) 
trix(2)=tx(f3)
triy(2)=ty(f3)
'SHAPE 3, trix, triy

'Calculate Non Defined Co-Ordinates.
xt=(tx(f1)+tx(f2))/2 'Find Top Centre X
yt=(ty(f1)+ty(f2))/2 'Find Top Centre y
cx(1)=(xt+tx(f1))/2 'Calculate xpos 1
cy(1)=(yt+ty(f1))/2 'Calculate Ypos 1
cx(2)=(xt+tx(f2))/2 'Calculate xpos 2 
cy(2)=(yt+ty(f2))/2 'Calculate Ypos 2
xt=(tx(f2)+tx(f3))/2 'Find side Centre X
yt=(ty(f2)+ty(f3))/2 'Find side Centre y
cx(3)=(xt+tx(f2))/2 'Calculate xpos 3
cy(3)=(yt+ty(f2))/2 'Calculate Ypos 3
cx(4)=(xt+tx(f3))/2 'Calculate xpos 4
cy(4)=(yt+ty(f3))/2 'Calculate Ypos 4
xt=(tx(f3)+tx(f4))/2 'Find bottom Centre X
yt=(ty(f3)+ty(f4))/2 'Find bottom Centre y
cx(5)=(xt+tx(f3))/2 'Calculate xpos 5
cy(5)=(yt+ty(f3))/2 'Calculate Ypos 5
cx(6)=(xt+tx(f4))/2 'Calculate xpos 6
cy(6)=(yt+ty(f4))/2 'Calculate Ypos 6
xt=(tx(f4)+tx(f1))/2 'Find side Centre X
yt=(ty(f4)+ty(f1))/2 'Find side Centre y
cx(7)=(xt+tx(f4))/2 'Calculate xpos 7
cy(7)=(yt+ty(f4))/2 'Calculate Ypos 7
cx(8)=(xt+tx(f1))/2 'Calculate xpos 8
cy(8)=(yt+ty(f1))/2 'Calculate Ypos 8
xt=(cx(1)+cx(6))/2 'Find side offset Centre 1
yt=(cy(1)+cy(6))/2 'Find side offset Centre 1
cx(9)=(xt+cx(1))/2 'Calculate xpos 9
cy(9)=(yt+cy(1))/2 'Calculate Ypos 9
cx(10)=(xt+cx(6))/2 'Calculate xpos 10
cy(10)=(yt+cy(6))/2 'Calculate Ypos 10
xt=(cx(2)+cx(5))/2 'Find side offset Centre 2
yt=(cy(2)+cy(5))/2 'Find side offset Centre 2
cx(11)=(xt+cx(2))/2 'Calculate xpos 11
cy(11)=(yt+cy(2))/2 'Calculate Ypos 11
cx(12)=(xt+cx(5))/2 'Calculate xpos 12
cy(12)=(yt+cy(5))/2 'Calculate Ypos 12

'Draw Red Polygons
fill COLOR .light,0,0
'triangle tx(f1),ty(f1) to cx(1),cy(1) to cx(9),cy(9)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(1)
triy(1)=cy(1) 
trix(2)=cx(9)
triy(2)=cy(9)
fill poly trix, triy count 3
'triangle tx(f1),ty(f1) to cx(9),cy(9) to cx(8),cy(8)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(9)
triy(1)=cy(9) 
trix(2)=cx(8)
triy(2)=cy(8)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(2),cy(2) to cx(11),cy(11)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(2)
triy(1)=cy(2) 
trix(2)=cx(11)
triy(2)=cy(11)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(11),cy(11) to cx(3),cy(3)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(11)
triy(1)=cy(11) 
trix(2)=cx(3)
triy(2)=cy(3)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(4),cy(4) to cx(12),cy(12)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(4)
triy(1)=cy(4) 
trix(2)=cx(12)
triy(2)=cy(12)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(12),cy(12) to cx(5),cy(5)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(12)
triy(1)=cy(12) 
trix(2)=cx(5)
triy(2)=cy(5)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(6),cy(6) to cx(10),cy(10)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(6)
triy(1)=cy(6) 
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(10),cy(10) to cx(7),cy(7)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(10)
triy(1)=cy(10) 
trix(2)=cx(7)
triy(2)=cy(7)
fill poly trix, triy count 3

'Draw The Green Polygons
fill COLOR 0,.light,0
'triangle cx(9),cy(9) to cx(11),cy(11) to cx(10),cy(10)
trix(0)=cx(9)
triy(0)=cy(9)
trix(1)=cx(11)
triy(1)=cy(11) 
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3
'triangle cx(12),cy(12) to cx(11),cy(11) to cx(10),cy(10)
trix(0)=cx(12)
triy(0)=cy(12)
trix(1)=cx(11)
triy(1)=cy(11) 
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3

'Black Lines
draw COLOR 40,110,150
draw LINE tx(f1),ty(f1) to tx(f2),ty(f2)
draw LINE tx(f2),ty(f2) to tx(f3),ty(f3)
draw LINE tx(f3),ty(f3) to tx(f4),ty(f4)
draw LINE tx(f4),ty(f4) to tx(f1),ty(f1)
draw LINE cx(1),cy(1) to cx(6),cy(6)
draw LINE cx(2),cy(2) to cx(5),cy(5)
draw LINE cx(3),cy(3) to cx(8),cy(8)
draw LINE cx(4),cy(4) to cx(7),cy(7)
END IF

RETURN

'This Subroutine Rotates The Eight Corner Points About
'Thier X,Y and Z Axis Using Matrices And Applys A
'Perspective Formula To The Transformed Points.
'All Logical Points are derived from these 8.

rotate:

'Rotate And Scale Each Point - Store Result 
FOR a=1 TO polys
x1=x(a)
y1=y(a)
z1=z(a)

'X,Y,Z rotations! 
xx=x1
yy=y1*cs(xr)+z1*sn(xr)
zz=z1*cs(xr)-y1*sn(xr)
y1=yy
x1=xx*cs(yr)-zz*sn(yr)
z1=xx*sn(yr)+zz*cs(yr)
zz=z1
xx=x1*cs(zr)-y1*sn(zr)
yy=x1*sn(zr)+y1*cs(zr)

'Apply Perspective! 
xx=size*(xx/((zz/50)+1))+sw/2
yy=size*(yy/((zz/50)+1))+sh/2 
tx(a)=xx
ty(a)=yy
tz(a)=zz
NEXT a

' Incriment Rotations! 
xr=xr+3
yr=yr+2
zr=zr+1
IF xr>720 THEN
xr=xr-720
END IF
IF yr>720 THEN
yr=yr-720
END IF
IF zr>720 THEN
zr=zr-720
END IF
RETURN

initialize:
sw=Screen_Width()
sh=Screen_Height()
csw=sw/2
csh=sh/2
pi = 3.1415
' This Sub-Routine Initializes The Program.

'Scroll Variables
s$=" "
s$=s$&"CAN YOU GUESS WHY THIS IS CALLED THE ACETAMINOPHEN"
s$=s$&"??? NO??? WELL WATCH IT FOR HALF AN HOUR "
s$=s$&"AND YOU'LL FIND OUT THE HARD WAY.... GUARANTEED"
s$=s$&" TO CAUSE A BLINDING HEADACHE... I TRIED TO MAKE "
s$=s$&"SOMETHING COLORFUL. "
p=0
scx=0


' Writer Variables
messages=17 ' How Many text lines?
mc=1
DIM m$(messages+2) 'Set Space For Them
FOR a=1 TO messages 'Read Them In
READ m$(a)
NEXT a

'Define the necessary variables! 
size=12 'how big do you want it?
polys=8 'The amount of vertices in the object
DIM x(polys+1) 'Original X co-ordinate store
DIM y(polys+1) 'Original Y co-ordinate store
DIM z(polys+1) 'Original Z co-ordinate store
DIM tx(polys+1) 'Transformed X co-ordinate store
DIM ty(polys+1) 'Transformed Y co-ordinate store
DIM tz(polys+1) 'Transformed Z co-ordinate store
DIM cx(13) ' Storage For Calculated X
DIM cy(13) ' Storage For Calculated Y
DIM trix(4),triy(4) ' triangle 

xr=3
yr=2
zr=1

'Define Sine Tables!! 
DIM cs(722)
DIM sn(722)
FOR ang=0 TO 720
cs(ang)=COS(ang*(PI/360))
sn(ang)=SIN(ang*(PI/360))
NEXT ang

' Read in the object! 
FOR a=1 TO polys
READ x(a),y(a),z(a)
NEXT a

text: 
DATA "WELCOME TO","ACETAMINOPHEN"
DATA "BASIC RULES!","3D MANIPULATION"
DATA "MULTI MESSAGES","PRECALCULATED MATH"
DATA "HIDDEN LINES","3D ROTATIONS"
DATA "TRON COLORS!","AWESOME BASIC"
DATA "HI TO:","DUTCHMAN"
DATA "OPERATOR","DIGIT"
DATA "MR K.","DR CHIP","FORUM MEMBERS!"

' The Object Description As Data!
' The Data Below Describes A Cube.
obj:
DATA -10,10,10,10,10,10,10,-10,10,-10,-10,10
DATA -10,10,-10,10,10,-10,10,-10,-10,-10,-10,-10
RETURN

[Mr. Kibernetik]

Note:
you can make your code considerably faster if you draw one 4 vertices polygon instead of two 3 vertices polygons.

For example, this code:

Code: Select all

'triangle tx(f3),ty(f3) to cx(4),cy(4) to cx(12),cy(12)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(4)
triy(1)=cy(4) 
trix(2)=cx(12)
triy(2)=cy(12)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(12),cy(12) to cx(5),cy(5)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(12)
triy(1)=cy(12) 
trix(2)=cx(5)
triy(2)=cy(5)
fill poly trix, triy count 3

can be replaced with this code:

Code: Select all

'triangle tx(f3),ty(f3) to cx(4),cy(4) to cx(12),cy(12)
'triangle tx(f3),ty(f3) to cx(12),cy(12) to cx(5),cy(5)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(4)
triy(1)=cy(4) 
trix(2)=cx(12)
triy(2)=cy(12)
trix(3)=cx(5)
triy(3)=cy(5)
fill poly trix, triy count 4

[DrChip]

REM ACETAMINOPHEN v2
REM You'll need some afterwards
REM iPhone 6 plus
REM v2 - optimized using Mr. K's advice!
REM enjoy
REM the shapes in the blue
REM to get a cool effect!!

def reload
notes load "/Examples/10. Music & Sound/files/test5.mid"
notes play
enddef

reload

graphics
'Program Notes: This demo started life as a wire frame
'3D routine that I developed to model a simple 3D cube....
'My previous 3D had depth sorted faces, this one uses a
'hidden line algorithm that checks if the points of a given
'face are in clockwise or
'anticlockwise order to see if they should
'be drawn.... I Added some light sourcing
'to the cube, and borrowed an idea from
'my other demos.

'Set Everything up
GOSUB initialize
refresh off

option screenlock off
dgc=0.01
dgcr=dgc!dgcg=dgc!dgcb=dgc
gcr=0!gcg=.33!gcb=.66

' Main Loop
loop:
if notes_time()>notes_length() then reload
'Draw Backround
gcr+=dgcr!gcg+=dgcg!gcb+=dgcb
if gcr>1 or gcr<0 then dgcr=-dgcr
if gcg>1 or gcg<0 then dgcg=-dgcg
if gcb>1 or gcb<0 then dgcb=-dgcb
graphics clear gcr,gcg,gcb

'Call Rotation Routine
GOSUB rotate

'Draw Inside Faces
'Color 10,30,10
f1=1
f2=2
f3=3
f4=4 'Face 1
GOSUB draw 'Draw Face 1
f1=5
f2=8
f3=7
f4=6 'Face 2
GOSUB draw 'Draw Face 2
f1=6
f2=2
f3=1
f4=5 'Face 3
GOSUB draw 'Draw Face 3
f1=8
f2=4
f3=3
f4=7 ' Face 4
GOSUB draw 'Draw Face 4
f1=2
f2=6
f3=7
f4=3 'Face 5
GOSUB draw 'Draw Face 5
f1=8
f2=5
f3=1
f4=4 'Face 6
GOSUB draw 'Draw Face 6

' Draw Outside Faces
f1=1
f2=2
f3=3
f4=4 'Face 1
GOSUB draw2 'Draw Face 1
f1=5
f2=8
f3=7
f4=6 'Face 2
GOSUB draw2 'Draw Face 2
f1=6
f2=2
f3=1
f4=5 'Face 3
GOSUB draw2 'Draw Face 3
f1=8
f2=4
f3=3
f4=7 'Face 4
GOSUB draw2 'Draw Face 4
f1=2
f2=6
f3=7
f4=3 'Face 5
GOSUB draw2 'Draw Face 5
f1=8
f2=5
f3=1
f4=4 'Face 6
GOSUB draw2 'Draw Face 6

'Display Text
stext$=substr$(s$,p,len(s$)-1)
draw COLOR 0,0,0
DRAW TEXT "ACETAMINOPHEN" at 0,2
DRAW TEXT stext$ at scx+2,sch-18
draw COLOR 1,1,1
DRAW TEXT "ACETAMINOPHEN" at 0,0
'DRAW TEXT stext$ at scx,sch-20

'Scroller Code


ls=len(s$)-1
text$=substr$(s$,p,ls)
draw color 0,0,0
draw text text$ at scx+2,sh-18
draw color 1,1,1
draw text text$ at scx,sh-20


'draw text substr$(s$,p,ls) at scx,texty
scx-=1
if scx<-50 then
scx+=10
p+=1
if p>ls then p=1
end if


GOSUB writer
refresh
GOTO loop
'Main Loop Ends

'Subroutines

'This Subroutine Does The Bouncy Greetings Thing;

writer:
mm=mm+.05
IF mm>4 THEN
mm=0
mc=mc+1
IF mc>messages THEN
mc=1
END IF
END IF
draw COLOR 1,1,1
DRAW TEXT m$(mc) at csw-LEN(m$(mc))*5,70*SIN(mm)
RETURN

'Subroutine To Draw One Inner Face From 4 Passed Points
'This Will Only Draw The Face If It Is Behind.

draw:
'Calculate Poly Positions And Draw One Complete Face

'Hidden Line Removal Algorithm
vx1= tx(f1)-tx(f2)
vy1= ty(f1)-ty(f2)
vx2= tx(f3)-tx(f2)
vy2= ty(f3)-ty(f2)
IF (vx1*vy2)-(vx2*vy1)>0 THEN

'Lightsource Color
light=(tz(1)+tz(f2)+tz(f3)+tz(f4)*3)
' light=light+50
fill COLOR 0,0,light/255

'Draw Background of face (blue)

'triangle tx(f1),ty(f1) to tx(f2),ty(f2) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f2)
triy(1)=ty(f2)
trix(2)=tx(f3)
triy(2)=ty(f3)
fill poly trix, triy count 3
'gtriangle tx(f1),ty(f1) to tx(f4),ty(f4) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f4)
triy(1)=ty(f4)
trix(2)=tx(f3)
triy(2)=ty(f3)
fill poly trix, triy count 3

'Calculate Non Defined Co-Ordinates.
xt=(tx(f1)+tx(f2))/2 'Find Top Centre X
yt=(ty(f1)+ty(f2))/2 'Find Top Centre y
cx(1)=(xt+tx(f1))/2 'Calculate xpos 1
cy(1)=(yt+ty(f1))/2 'Calculate Ypos 1
cx(2)=(xt+tx(f2))/2 'Calculate xpos 2
cy(2)=(yt+ty(f2))/2 'Calculate Ypos 2
xt=(tx(f2)+tx(f3))/2 'Find side Centre X
yt=(ty(f2)+ty(f3))/2 'Find side Centre y
cx(3)=(xt+tx(f2))/2 'Calculate xpos 3
cy(3)=(yt+ty(f2))/2 'Calculate Ypos 3
cx(4)=(xt+tx(f3))/2 'Calculate xpos 4
cy(4)=(yt+ty(f3))/2 'Calculate Ypos 4
xt=(tx(f3)+tx(f4))/2 'Find bottom Centre X
yt=(ty(f3)+ty(f4))/2 'Find bottom Centre y
cx(5)=(xt+tx(f3))/2 'Calculate xpos 5
cy(5)=(yt+ty(f3))/2 'Calculate Ypos 5
cx(6)=(xt+tx(f4))/2 'Calculate xpos 6
cy(6)=(yt+ty(f4))/2 'Calculate Ypos 6
xt=(tx(f4)+tx(f1))/2 'Find side Centre X
yt=(ty(f4)+ty(f1))/2 'Find side Centre y
cx(7)=(xt+tx(f4))/2 'Calculate xpos 7
cy(7)=(yt+ty(f4))/2 'Calculate Ypos 7
cx(8)=(xt+tx(f1))/2 'Calculate xpos 8
cy(8)=(yt+ty(f1))/2 'Calculate Ypos 8
xt=(cx(1)+cx(6))/2 'Find side offset Centre 1
yt=(cy(1)+cy(6))/2 'Find side offset Centre 1
cx(9)=(xt+cx(1))/2 'Calculate xpos 9
cy(9)=(yt+cy(1))/2 'Calculate Ypos 9
cx(10)=(xt+cx(6))/2 'Calculate xpos 10
cy(10)=(yt+cy(6))/2 'Calculate Ypos 10
xt=(cx(2)+cx(5))/2 'Find side offset Centre 2
yt=(cy(2)+cy(5))/2 'Find side offset Centre 2
cx(11)=(xt+cx(2))/2 'Calculate xpos 11
cy(11)=(yt+cy(2))/2 'Calculate Ypos 11
cx(12)=(xt+cx(5))/2 'Calculate xpos 12
cy(12)=(yt+cy(5))/2 'Calculate Ypos 12

'Draw Red Polygons
fill COLOR .light,0,0
'triangle tx(f1),ty(f1) to cx(1),cy(1) to cx(9),cy(9)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(1)
triy(1)=cy(1)
trix(2)=cx(9)
triy(2)=cy(9)
fill poly trix, triy count 3
'gtriangle tx(f1),ty(f1) to cx(9),cy(9) to cx(8),cy(8)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(9)
triy(1)=cy(9)
trix(2)=cx(8)
triy(2)=cy(8)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(2),cy(2) to cx(11),cy(11)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(2)
triy(1)=cy(2)
trix(2)=cx(11)
triy(2)=cy(11)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(11),cy(11) to cx(3),cy(3)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(11)
triy(1)=cy(11)
trix(2)=cx(3)
triy(2)=cy(3)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(4),cy(4) to cx(12),cy(12)
'triangle tx(f3),ty(f3) to cx(12),cy(12) to cx(5),cy(5)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(4)
triy(1)=cy(4)
trix(2)=cx(12)
triy(2)=cy(12)
trix(3)=cx(5)
triy(3)=cy(5)
fill poly trix, triy count 4
'triangle tx(f4),ty(f4) to cx(6),cy(6) to cx(10),cy(10)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(6)
triy(1)=cy(6)
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(10),cy(10) to cx(7),cy(7)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(10)
triy(1)=cy(10)
trix(2)=cx(7)
triy(2)=cy(7)
fill poly trix, triy count 3

' Draw The Green Polygons
fill COLOR 0,.light,0
'triangle cx(9),cy(9) to cx(10),cy(10) to cx(11),cy(11)
trix(0)=cx(9)
triy(0)=cy(9)
trix(1)=cx(10)
triy(1)=cy(10)
trix(2)=cx(11)
triy(2)=cy(11)
fill poly trix, triy count 3
'triangle cx(12),cy(12) to cx(11),cy(11) to cx(10),cy(10)
trix(0)=cx(12)
triy(0)=cy(12)
trix(1)=cx(11)
triy(1)=cy(11)
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3

'Draw Red Tron Lines
draw COLOR 1,0,0
draw LINE tx(f1),ty(f1) to tx(f2),ty(f2)
draw LINE tx(f2),ty(f2) to tx(f3),ty(f3)
draw LINE tx(f3),ty(f3) to tx(f4),ty(f4)
draw LINE tx(f4),ty(f4) to tx(f1),ty(f1)
draw LINE cx(1),cy(1) to cx(6),cy(6)
draw LINE cx(2),cy(2) to cx(5),cy(5)
draw LINE cx(3),cy(3) to cx(8),cy(8)
draw LINE cx(4),cy(4) to cx(7),cy(7)
END IF
RETURN

'Subroutine To Draw One Outer Face From 4 Passed Points
'This Wil Only Draw The Face If It Is In Front.

draw2:
' Calculate Poly Positions And Draw One Complete Face

'Hidden Line Removal Algorithm
'watch this will be in my writings
vx1= tx(f1)-tx(f2)
vy1= ty(f1)-ty(f2)
vx2= tx(f3)-tx(f2)
vy2= ty(f3)-ty(f2)
IF (vx1*vy2)-(vx2*vy1)<0 THEN

'Lightsource Color
light=-(tz(1)+tz(f2)+tz(f3)+tz(f4))*5
light=light+50
fill COLOR 0,0,.light

'Draw Background of face (blue)
'comment the shape yo see a cool efx!
'' fill triangle tx(f1),ty(f1) to tx(f2),ty(f2) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f2)
triy(1)=ty(f2)
trix(2)=tx(f3)
triy(2)=ty(f3)
'SHAPE 3, trix, triy
'comment the SHAPE to see a cool efx!
'' triangle tx(f1),ty(f1) to tx(f4),ty(f4) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f4)
triy(1)=ty(f4)
trix(2)=tx(f3)
triy(2)=ty(f3)
'SHAPE 3, trix, triy

'Calculate Non Defined Co-Ordinates.
xt=(tx(f1)+tx(f2))/2 'Find Top Centre X
yt=(ty(f1)+ty(f2))/2 'Find Top Centre y
cx(1)=(xt+tx(f1))/2 'Calculate xpos 1
cy(1)=(yt+ty(f1))/2 'Calculate Ypos 1
cx(2)=(xt+tx(f2))/2 'Calculate xpos 2
cy(2)=(yt+ty(f2))/2 'Calculate Ypos 2
xt=(tx(f2)+tx(f3))/2 'Find side Centre X
yt=(ty(f2)+ty(f3))/2 'Find side Centre y
cx(3)=(xt+tx(f2))/2 'Calculate xpos 3
cy(3)=(yt+ty(f2))/2 'Calculate Ypos 3
cx(4)=(xt+tx(f3))/2 'Calculate xpos 4
cy(4)=(yt+ty(f3))/2 'Calculate Ypos 4
xt=(tx(f3)+tx(f4))/2 'Find bottom Centre X
yt=(ty(f3)+ty(f4))/2 'Find bottom Centre y
cx(5)=(xt+tx(f3))/2 'Calculate xpos 5
cy(5)=(yt+ty(f3))/2 'Calculate Ypos 5
cx(6)=(xt+tx(f4))/2 'Calculate xpos 6
cy(6)=(yt+ty(f4))/2 'Calculate Ypos 6
xt=(tx(f4)+tx(f1))/2 'Find side Centre X
yt=(ty(f4)+ty(f1))/2 'Find side Centre y
cx(7)=(xt+tx(f4))/2 'Calculate xpos 7
cy(7)=(yt+ty(f4))/2 'Calculate Ypos 7
cx(8)=(xt+tx(f1))/2 'Calculate xpos 8
cy(8)=(yt+ty(f1))/2 'Calculate Ypos 8
xt=(cx(1)+cx(6))/2 'Find side offset Centre 1
yt=(cy(1)+cy(6))/2 'Find side offset Centre 1
cx(9)=(xt+cx(1))/2 'Calculate xpos 9
cy(9)=(yt+cy(1))/2 'Calculate Ypos 9
cx(10)=(xt+cx(6))/2 'Calculate xpos 10
cy(10)=(yt+cy(6))/2 'Calculate Ypos 10
xt=(cx(2)+cx(5))/2 'Find side offset Centre 2
yt=(cy(2)+cy(5))/2 'Find side offset Centre 2
cx(11)=(xt+cx(2))/2 'Calculate xpos 11
cy(11)=(yt+cy(2))/2 'Calculate Ypos 11
cx(12)=(xt+cx(5))/2 'Calculate xpos 12
cy(12)=(yt+cy(5))/2 'Calculate Ypos 12

'Draw Red Polygons
fill COLOR .light,0,0
'triangle tx(f1),ty(f1) to cx(1),cy(1) to cx(9),cy(9)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(1)
triy(1)=cy(1)
trix(2)=cx(9)
triy(2)=cy(9)
fill poly trix, triy count 3
'triangle tx(f1),ty(f1) to cx(9),cy(9) to cx(8),cy(8)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=cx(9)
triy(1)=cy(9)
trix(2)=cx(8)
triy(2)=cy(8)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(2),cy(2) to cx(11),cy(11)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(2)
triy(1)=cy(2)
trix(2)=cx(11)
triy(2)=cy(11)
fill poly trix, triy count 3
'triangle tx(f2),ty(f2) to cx(11),cy(11) to cx(3),cy(3)
trix(0)=tx(f2)
triy(0)=ty(f2)
trix(1)=cx(11)
triy(1)=cy(11)
trix(2)=cx(3)
triy(2)=cy(3)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(4),cy(4) to cx(12),cy(12)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(4)
triy(1)=cy(4)
trix(2)=cx(12)
triy(2)=cy(12)
fill poly trix, triy count 3
'triangle tx(f3),ty(f3) to cx(12),cy(12) to cx(5),cy(5)
trix(0)=tx(f3)
triy(0)=ty(f3)
trix(1)=cx(12)
triy(1)=cy(12)
trix(2)=cx(5)
triy(2)=cy(5)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(6),cy(6) to cx(10),cy(10)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(6)
triy(1)=cy(6)
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3
'triangle tx(f4),ty(f4) to cx(10),cy(10) to cx(7),cy(7)
trix(0)=tx(f4)
triy(0)=ty(f4)
trix(1)=cx(10)
triy(1)=cy(10)
trix(2)=cx(7)
triy(2)=cy(7)
fill poly trix, triy count 3

'Draw The Green Polygons
fill COLOR 0,.light,0
'triangle cx(9),cy(9) to cx(11),cy(11) to cx(10),cy(10)
trix(0)=cx(9)
triy(0)=cy(9)
trix(1)=cx(11)
triy(1)=cy(11)
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3
'triangle cx(12),cy(12) to cx(11),cy(11) to cx(10),cy(10)
trix(0)=cx(12)
triy(0)=cy(12)
trix(1)=cx(11)
triy(1)=cy(11)
trix(2)=cx(10)
triy(2)=cy(10)
fill poly trix, triy count 3

'Black Lines
draw COLOR 40,110,150
draw LINE tx(f1),ty(f1) to tx(f2),ty(f2)
draw LINE tx(f2),ty(f2) to tx(f3),ty(f3)
draw LINE tx(f3),ty(f3) to tx(f4),ty(f4)
draw LINE tx(f4),ty(f4) to tx(f1),ty(f1)
draw LINE cx(1),cy(1) to cx(6),cy(6)
draw LINE cx(2),cy(2) to cx(5),cy(5)
draw LINE cx(3),cy(3) to cx(8),cy(8)
draw LINE cx(4),cy(4) to cx(7),cy(7)
END IF

RETURN

'This Subroutine Rotates The Eight Corner Points About
'Thier X,Y and Z Axis Using Matrices And Applys A
'Perspective Formula To The Transformed Points.
'All Logical Points are derived from these 8.

rotate:

'Rotate And Scale Each Point - Store Result
FOR a=1 TO polys
x1=x(a)
y1=y(a)
z1=z(a)

'X,Y,Z rotations!
xx=x1
yy=y1*cs(xr)+z1*sn(xr)
zz=z1*cs(xr)-y1*sn(xr)
y1=yy
x1=xx*cs(yr)-zz*sn(yr)
z1=xx*sn(yr)+zz*cs(yr)
zz=z1
xx=x1*cs(zr)-y1*sn(zr)
yy=x1*sn(zr)+y1*cs(zr)

'Apply Perspective!
xx=size*(xx/((zz/50)+1))+sw/2
yy=size*(yy/((zz/50)+1))+sh/2
tx(a)=xx
ty(a)=yy
tz(a)=zz
NEXT a

' Incriment Rotations!
xr=xr+3
yr=yr+2
zr=zr+1
IF xr>720 THEN
xr=xr-720
END IF
IF yr>720 THEN
yr=yr-720
END IF
IF zr>720 THEN
zr=zr-720
END IF
RETURN

initialize:
sw=Screen_Width()
sh=Screen_Height()
csw=sw/2
csh=sh/2
pi = 3.1415
' This Sub-Routine Initializes The Program.

'Scroll Variables
s$=" "
s$=s$&"CAN YOU GUESS WHY THIS IS CALLED THE ACETAMINOPHEN"
s$=s$&"??? NO??? WELL WATCH IT FOR HALF AN HOUR "
s$=s$&"AND YOU'LL FIND OUT THE HARD WAY.... GUARANTEED"
s$=s$&" TO CAUSE A BLINDING HEADACHE... I TRIED TO MAKE "
s$=s$&"SOMETHING COLORFUL. "
p=0
scx=0


' Writer Variables
messages=17 ' How Many text lines?
mc=1
DIM m$(messages+2) 'Set Space For Them
FOR a=1 TO messages 'Read Them In
READ m$(a)
NEXT a

'Define the necessary variables!
size=12 'how big do you want it?
polys=8 'The amount of vertices in the object
DIM x(polys+1) 'Original X co-ordinate store
DIM y(polys+1) 'Original Y co-ordinate store
DIM z(polys+1) 'Original Z co-ordinate store
DIM tx(polys+1) 'Transformed X co-ordinate store
DIM ty(polys+1) 'Transformed Y co-ordinate store
DIM tz(polys+1) 'Transformed Z co-ordinate store
DIM cx(13) ' Storage For Calculated X
DIM cy(13) ' Storage For Calculated Y
DIM trix(4),triy(4) ' triangle

xr=3
yr=2
zr=1

'Define Sine Tables!!
DIM cs(722)
DIM sn(722)
FOR ang=0 TO 720
cs(ang)=COS(ang*(PI/360))
sn(ang)=SIN(ang*(PI/360))
NEXT ang

' Read in the object!
FOR a=1 TO polys
READ x(a),y(a),z(a)
NEXT a

text:
DATA "WELCOME TO","ACETAMINOPHEN"
DATA "BASIC RULES!","3D MANIPULATION"
DATA "MULTI MESSAGES","PRECALCULATED MATH"
DATA "HIDDEN LINES","3D ROTATIONS"
DATA "TRON COLORS!","AWESOME BASIC"
DATA "HI TO:","DUTCHMAN"
DATA "OPERATOR","DIGIT"
DATA "MR K.","DR CHIP","FORUM MEMBERS!"

' The Object Description As Data!
' The Data Below Describes A Cube.
obj:
DATA -10,10,10,10,10,10,10,-10,10,-10,-10,10
DATA -10,10,-10,10,10,-10,10,-10,-10,-10,-10,-10
RETURN

[Mr. Kibernetik]

This my note about polygons optimization is about almost all your triangles, not only one pair.

You see, for example in this your code:

Code: Select all

'triangle tx(f1),ty(f1) to tx(f2),ty(f2) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f2)
triy(1)=ty(f2) 
trix(2)=tx(f3)
triy(2)=ty(f3)
fill poly trix, triy count 3
'gtriangle tx(f1),ty(f1) to tx(f4),ty(f4) to tx(f3),ty(f3)
trix(0)=tx(f1)
triy(0)=ty(f1)
trix(1)=tx(f4)
triy(1)=ty(f4) 
trix(2)=tx(f3)
triy(2)=ty(f3)
fill poly trix, triy count 3

you draw a pair of triangles using points
tx(f1),ty(f1)
tx(f3),ty(f3)
tx(f2),ty(f2)
for one triangle and points
tx(f1),ty(f1)
tx(f3),ty(f3)
tx(f4),ty(f4)
for adjacent triangle.
But you can easily draw one 4-point rectangle instead of two 3-point adjacent triangles using the same points:
tx(f1),ty(f1)
tx(f2),ty(f2)
tx(f3),ty(f3)
tx(f4),ty(f4)
And this is over all your program. Do you get my idea?