1 REM 3D ROTATE PROTOTYPE - TANDY 1000 8mhz
2 REM COPYRIGHT 1989 BROOKS DEFOREST
3 REM PUBLIC DOMAIN RELEASED 2007
4 I1=1:I2=9:I3=3
5 KEY OFF:SCREEN 3:SCREEN 4:PALETTE 0,0:PALETTE 1,1:PALETTE 2,9:PALETTE 3,3:CLS
6 VIEW PRINT 1 TO 25
10 DIM A(390):DIM B(390):DIM C(390):DIM D(390):DIM E(390):DIM F(390):DIM G(390):DIM H(390):DIM I(390):DIM J(390):DIM K(390):DIM L(390):DIM M(390):DIM N(390):DIM O(390):DIM P(400):DIM Q(390):DIM R(390):DIM S(390):DIM T(390):DIM U(390):DIM V(390):DIM W(390)
11 DIM X(390):DIM Y(390):DIM Z(390):DIM AA(400):DIM BB(390):DIM CC(390):DIM DD(390):DIM EE(390):DIM FF(390)
15 CLS
20 PP=1
21 XX=160:YY=150:XXX=160:YYY=50
25 X=160:Y=100:S1=45:S2=15:DP=20
26 VIEW SCREEN (X-S1,50)-(X+S1,115)
28 COLOR 1:C2=16:STP=.2
29 A1=.1:A2=1.8:A3=3.2:A4=4.9:P1=X:P2=Y-50:SCREEN 2:SCREEN 4:VIEW SCREEN(X-S1,50)-(X+S1,115):GOTO 500
30 FOR A=1 TO 7.2 STEP STP
35 X1=X+S1*COS(A+A1):Y1=Y+S2*SIN(A+A1)
40 X2=X+S1*COS(A+A2):Y2=Y+S2*SIN(A+A2)
45 X3=X+S1*COS(A+A3):Y3=Y+S2*SIN(A+A3)
46 X4=X+S1*COS(A+A4):Y4=Y+S2*SIN(A+A4)
49 CLS:GOTO 80
50 IF X1<X4 THEN C3=-2:LINE(X1,Y1)-(X4,Y4):LINE(X4,Y4)-(X4,Y4-DP):LINE(X1,Y1)-(X1,Y1-DP):LINE(X1,Y1-DP)-(X4,Y4-DP),1:LINE(X1,Y1-DP)-(P1,P2),1:LINE(X4,Y4-DP)-(P1,P2),1:IF PP=1 THEN PAINT(X1+C1,Y1-DP-14),1
55 IF X2<X1 THEN C4=0:LINE(X1,Y1)-(X2,Y2),1:LINE(X1,Y1)-(X1,Y1-DP),1:LINE(X2,Y2)-(X2,Y2-DP),1:LINE(X1,Y1-DP)-(X2,Y2-DP),1:LINE(X1,Y1-DP)-(P1,P2),2:LINE(X2,Y2-DP)-(P1,P2),2:LINE(X1,Y1-DP)-(X2,Y2-DP),2:IF PP=1 THEN PAINT(X2+C2,Y2-DP-12),2
56 IF PP=1 AND X2<X1 THEN LINE(X2,Y2-DP)-(X1,Y1-DP),1:PAINT(X2+1,Y2-7),1
60 IF X3<X2 THEN C1=0:LINE(X2,Y2)-(X3,Y3),2:LINE(X3,Y3-DP)-(X2,Y2-DP),3:LINE(X2,Y2)-(X2,Y2-DP),3:LINE(X3,Y3)-(X3,Y3-DP),3:LINE(X2,Y2-DP)-(P1,P2),3:LINE(X3,Y3-DP)-(P1,P2),3:IF PP=1 THEN PAINT(X3+C3,Y3-DP-15),3
61 IF PP=1 AND X3<X2 AND ROT=360 AND F<>14 THEN LINE(X3,Y3-DP)-(X2,Y2-DP),2:LINE(X2,Y2)-(X2,Y2-DP),2:LINE(X3,Y3)-(X3,Y3-DP),2:PAINT(X3+1,Y3-5),2
62 IF PP=1 AND X3<X2 AND ROT=180 AND F<>28 THEN LINE(X3,Y3-DP)-(X2,Y2-DP),2:LINE(X2,Y2)-(X2,Y2-DP),2:LINE(X3,Y3)-(X3,Y3-DP),2:PAINT(X3+1,Y3-5),2
64 IF X4<X3 THEN C2=-4:LINE(X3,Y3)-(X4,Y4),1:LINE(X3,Y3)-(X3,Y3-DP),1:LINE(X4,Y4)-(X4,Y4-DP),1:LINE(X3,Y3-DP)-(P1,P2),2:LINE(X4,Y4-DP)-(P1,P2),2:LINE(X3,Y3-DP)-(X4,Y4-DP),2:IF PP=1 THEN PAINT(X4+C4,Y4-DP-13),2
65 IF PP=1 AND X4<X3 THEN LINE(X3,Y3-DP)-(X4,Y4-DP),1:PAINT(X4+1,Y4-7),1
66 F=F+1:IF EF=1 THEN 67 ELSE IF EF=2 THEN 68 ELSE IF EF=3 THEN 69 ELSE 71
67 IF F<16 THEN A2=A2-.2:A4=A4+.2:GOTO 71 ELSE A2=A2+.2:A4=A4-.2:GOTO 71
68 S2=S2+4:S1=S1+3:P2=P2-3:Y=Y-2:GOTO 71
69 LINE(X1,Y1)-(X2,Y2),1:LINE(X1,Y1)-(X1,Y1-DP),1:LINE(X1,Y1-DP)-(X2,Y2-DP),1:LINE(X2,Y2-DP)-(X2,Y2),1:LINE(X1,Y1-DP)-(P1,P2),1:LINE(X2,Y2-DP)-(P1,P2),1:LINE(X2,Y2)-(X3,Y3),2:LINE(X2,Y2-DP)-(X3,Y3-DP),2:LINE(X3,Y3-DP)-(X3,Y3),2:LINE(X3,Y3-DP)-(P1,P2),2
70 LINE(X3,Y3)-(X4,Y4),3:LINE(X3,Y3-DP)-(X4,Y4-DP),3:LINE(X4,Y4-DP)-(X4,Y4),3:LINE(X4,Y4)-(X1,Y1),2:LINE(X4,Y4-DP)-(X1,Y1-DP),2:LINE(X4,Y4-DP)-(P1,P2),2:LINE(X3,Y3-DP)-(P1,P2),3
71 GOTO 100
74 IF F>32 THEN 75 ELSE NEXT
75 ZX=1:PALETTE 1,1:PALETTE 2,9:PALETTE 3,3:GOTO 500
80 IF ROT=180 AND X1<X4 THEN C1=C1+1.15 ELSE IF ROT=360 AND X1<X4 THEN C1=C1+2.3
81 IF ROT=180 AND X2<X1 THEN C2=C2+.9 ELSE IF ROT=360 AND X2<X1 THEN C2=C2+2.3
82 IF ROT=180 AND X3<X2 THEN C3=C3+1 ELSE IF ROT=360 AND X3<X2 THEN C3=C3+2
83 IF ROT=180 AND X4<X3 THEN C4=C4+1 ELSE IF ROT=360 AND X4<X3 THEN C4=C4+2
85 GOTO 50
100 Q=115:W=205
105 IF F=1 THEN GET(Q,50)-(W,115),A
106 IF F=2 THEN GET(Q,50)-(W,115),B
107 IF F=3 THEN GET(Q,50)-(W,115),C
108 IF F=4 THEN GET(Q,50)-(W,115),D
109 IF F=5 THEN GET(Q,50)-(W,115),E
110 IF F=6 THEN GET(Q,50)-(W,115),F
111 IF F=7 THEN GET(Q,50)-(W,115),G
112 IF F=8 THEN GET(Q,50)-(W,115),H
113 IF F=9 THEN GET(Q,50)-(W,115),I
114 IF F=10 THEN GET(Q,50)-(W,115),J
115 IF F=11 THEN GET(Q,50)-(W,115),K
116 IF F=12 THEN GET(Q,50)-(W,115),L
117 IF F=13 THEN GET(Q,50)-(W,115),M
118 IF F=14 THEN GET(Q,50)-(W,115),N
119 IF F=15 THEN GET(Q,50)-(W,115),O
120 IF F=16 THEN GET(Q,50)-(W,115),P
121 IF F=17 THEN GET(Q,50)-(W,115),Q
122 IF F=18 THEN GET(Q,50)-(W,115),R
123 IF F=19 THEN GET(Q,50)-(W,115),S
124 IF F=20 THEN GET(Q,50)-(W,115),T
125 IF F=21 THEN GET(Q,50)-(W,115),U
126 IF F=22 THEN GET(Q,50)-(W,115),V
127 IF F=23 THEN GET(Q,50)-(W,115),W
128 IF F=24 THEN GET(Q,50)-(W,115),X
129 IF F=25 THEN GET(Q,50)-(W,115),Y
130 IF F=26 THEN GET(Q,50)-(W,115),Z
131 IF F=27 THEN GET(Q,50)-(W,115),AA
132 IF F=28 THEN GET(Q,50)-(W,115),BB
133 IF F=29 THEN GET(Q,50)-(W,115),CC
134 IF F=30 THEN GET(Q,50)-(W,115),DD
135 IF F=31 THEN GET(Q,50)-(W,115),EE
136 IF F=32 THEN GET(Q,50)-(W,115),FF
140 GOTO 74
200 CLS:WHILE INKEY$<>CHR$(27):FOR F=1 TO 32
205 IF F=1 THEN PUT(Q,50),A,PSET
206 IF F=2 THEN PUT(Q,50),B,PSET
207 IF F=3 THEN PUT(Q,50),C,PSET
208 IF F=4 THEN PUT(Q,50),D,PSET
209 IF F=5 THEN PUT(Q,50),E,PSET
210 IF F=6 THEN PUT(Q,50),F,PSET
211 IF F=7 THEN PUT(Q,50),G,PSET
212 IF F=8 THEN PUT(Q,50),H,PSET
213 IF F=9 THEN PUT(Q,50),I,PSET
214 IF F=10 THEN PUT(Q,50),J,PSET
215 IF F=11 THEN PUT(Q,50),K,PSET
216 IF F=12 THEN PUT(Q,50),L,PSET
217 IF F=13 THEN PUT(Q,50),M,PSET
218 IF F=14 THEN PUT(Q,50),N,PSET
219 IF F=15 THEN PUT(Q,50),O,PSET
220 IF F=16 THEN PUT(Q,50),P,PSET
221 IF F=17 THEN PUT(Q,50),Q,PSET
222 IF F=18 THEN PUT(Q,50),R,PSET
223 IF F=19 THEN PUT(Q,50),S,PSET
224 IF F=20 THEN PUT(Q,50),T,PSET
225 IF F=21 THEN PUT(Q,50),U,PSET
226 IF F=22 THEN PUT(Q,50),V,PSET
227 IF F=23 THEN PUT(Q,50),W,PSET
228 IF F=24 THEN PUT(Q,50),X,PSET
229 IF F=25 THEN PUT(Q,50),Y,PSET
230 IF F=26 THEN PUT(Q,50),Z,PSET
231 IF F=27 THEN PUT(Q,50),AA,PSET
232 IF F=28 THEN PUT(Q,50),BB,PSET
233 IF F=29 THEN PUT(Q,50),CC,PSET
234 IF F=30 THEN PUT(Q,50),DD,PSET
235 IF F=31 THEN PUT(Q,50),EE,PSET
236 IF F=32 THEN PUT(Q,50),FF,PSET
237 FOR P=1 TO SP:NEXT
240 NEXT
245 WEND
250 GOTO 500
300 GOTO 200
400 LOCATE 24,9:PRINT "USE (4)+(6) FOR SELECTION":CLS
401 A$=INKEY$:IF A$="" THEN 401
402 IF A$="4" THEN F=F-1:GOTO 403 ELSE IF A$="6" THEN F=F+1:GOTO 403 ELSE IF A$=CHR$(27) THEN LOCATE 24,1:PRINT STRING$(40,32):GOTO 550 ELSE 401
403 IF F>32 THEN F=1 ELSE IF F<1 THEN F=32
404 COLOR 2:LOCATE 22,5:PRINT "FRAME = "F"  "
405 IF F=1 THEN PUT(Q,50),A,PSET
406 IF F=2 THEN PUT(Q,50),B,PSET
407 IF F=3 THEN PUT(Q,50),C,PSET
408 IF F=4 THEN PUT(Q,50),D,PSET
409 IF F=5 THEN PUT(Q,50),E,PSET
410 IF F=6 THEN PUT(Q,50),F,PSET
411 IF F=7 THEN PUT(Q,50),G,PSET
412 IF F=8 THEN PUT(Q,50),H,PSET
413 IF F=9 THEN PUT(Q,50),I,PSET
414 IF F=10 THEN PUT(Q,50),J,PSET
415 IF F=11 THEN PUT(Q,50),K,PSET
416 IF F=12 THEN PUT(Q,50),L,PSET
417 IF F=13 THEN PUT(Q,50),M,PSET
418 IF F=14 THEN PUT(Q,50),N,PSET
419 IF F=15 THEN PUT(Q,50),O,PSET
420 IF F=16 THEN PUT(Q,50),P,PSET
421 IF F=17 THEN PUT(Q,50),Q,PSET
422 IF F=18 THEN PUT(Q,50),R,PSET
423 IF F=19 THEN PUT(Q,50),S,PSET
424 IF F=20 THEN PUT(Q,50),T,PSET
425 IF F=21 THEN PUT(Q,50),U,PSET
426 IF F=22 THEN PUT(Q,50),V,PSET
427 IF F=23 THEN PUT(Q,50),W,PSET
428 IF F=24 THEN PUT(Q,50),X,PSET
429 IF F=25 THEN PUT(Q,50),Y,PSET
430 IF F=26 THEN PUT(Q,50),Z,PSET
431 IF F=27 THEN PUT(Q,50),AA,PSET
432 IF F=28 THEN PUT(Q,50),BB,PSET
433 IF F=29 THEN PUT(Q,50),CC,PSET
434 IF F=30 THEN PUT(Q,50),DD,PSET
435 IF F=31 THEN PUT(Q,50),EE,PSET
436 IF F=32 THEN PUT(Q,50),FF,PSET
440 GOTO 401
500 COLOR 3:LOCATE 5,1:PRINT "3D DEMO":COLOR 2:LOCATE 1,12:PRINT "(C)1989 B.DEFOREST":COLOR 3:PALETTE 1,I1:PALETTE 2,I2:PALETTE 3,I3
501 IF EF=0 THEN V$="NORMAL (EXTERNAL)" ELSE IF EF=1 THEN V$="EXTERNAL > INTERNAL" ELSE IF EF=2 THEN V$="GRADUATING" ELSE IF EF=3 THEN V$="COMPLETE DIAGRAM"
502 IF STP=.1 THEN ROT=180 ELSE ROT=360
505 LOCATE 6,1:PRINT "-----------"
510 COLOR 1:LOCATE 8,1:PRINT "B DEPTH"DP"  "
515 LOCATE 10,1:PRINT "P DEPTH"Y-P2"   "
520 LOCATE 12,1:PRINT "ROTATION"ROT"  "
525 LOCATE 14,1:IF PP=0 THEN PRINT "WIREFRAME" ELSE PRINT "FILLED    "
530 LOCATE 16,1:PRINT "TILT"S2"  "
535 LOCATE 18,1:PRINT "WIDTH"S1"  "
540 LOCATE 8,30:PRINT "EQ A="A1"  "
541 LOCATE 10,30:PRINT "EQ B="A2"  "
542 LOCATE 12,30:PRINT "EQ C="A3"  "
543 LOCATE 14,30:PRINT "EQ D="A4"  "
544 COLOR 3:LOCATE 20,10:PRINT "VIEW = "V$
545 COLOR 2:LOCATE 22,5:PRINT "FRAME = "F:LOCATE 22,25:PRINT "SPEED = "SP"     "
550 COLOR 3:LOCATE 24,13:PRINT "READY FOR OPTION"
554 GOTO 900
555 A$=INKEY$:COLOR 1
556 IF A$="B" THEN GOSUB 590:GOTO 600
557 IF A$="P" THEN GOSUB 590:GOTO 605
558 IF A$="R" AND ROT=180 THEN ROT=360:STP=.2:GOSUB 590:GOTO 520
559 IF A$="R" AND ROT=360 THEN ROT=180:STP=.1:GOSUB 590:GOTO 520
560 IF A$=" " AND PP=1 THEN PP=0:GOSUB 590:GOTO 525
561 IF A$=" " AND PP=0 THEN PP=1:GOSUB 590:GOTO 525
562 IF A$="T" THEN GOSUB 590:GOTO 610
563 IF A$="W" THEN GOSUB 590:GOTO 615
564 IF A$="E" THEN GOSUB 590:GOTO 620
565 IF A$="V" THEN EF=EF+1:IF EF=4 THEN EF=0
566 IF A$="V" THEN GOSUB 590:LOCATE 20,1:PRINT STRING$(40,32):GOTO 501
567 IF A$="S" THEN GOSUB 590:GOTO 650
568 IF A$="Z" AND ZX=1 THEN GOSUB 590:GOTO 200
569 IF A$="Q" THEN COLOR 3:LOCATE 11,17:PRINT "RESTORING":GOTO 20
570 IF A$=CHR$(13) THEN GOSUB 590:GOTO 700
571 IF A$="F" AND ZX=1 THEN GOSUB 590:GOTO 400
572 IF A$="I" THEN 800
580 GOTO 915
590 LOCATE 24,13:PRINT STRING$(16,32):BEEP:RETURN
599 END
600 LOCATE 24,1:INPUT "ENTER NEW B DEPTH:",DP:LOCATE 24,1:PRINT STRING$(40,32):GOTO 510
605 LOCATE 24,1:INPUT "ENTER NEW P DEPTH:",PS:P2=Y-PS:LOCATE 24,1:PRINT STRING$(40,32):GOTO 515
610 LOCATE 24,1:INPUT "ENTER NEW TILT FACTOR:",S2:LOCATE 24,1:PRINT STRING$(40,32):GOTO 530
615 LOCATE 24,1:INPUT "ENTER NEW WIDTH:",S1:LOCATE 24,1:PRINT STRING$(40,32):GOTO 535
620 LOCATE 24,1:INPUT "ENTER EQ LETTER:",L$:LOCATE 24,1:PRINT STRING$(40,32)
621 IF L$="A" THEN LOCATE 24,1:INPUT "ENTER EQ ~A~:",A1
622 IF L$="B" THEN LOCATE 24,1:INPUT "ENTER EQ ~B~:",A2
623 IF L$="C" THEN LOCATE 24,1:INPUT "ENTER EQ ~C~:",A3
624 IF L$="D" THEN LOCATE 24,1:INPUT "ENTER EQ ~D~:",A4
625 LOCATE 24,1:PRINT STRING$(40,32):GOTO 540
650 LOCATE 24,1:INPUT "ENTER NEW SPEED:",SP:LOCATE 24,1:PRINT STRING$(40,32):GOTO 545
700 F=0:C2=16:C3=-2:C4=0:C1=-2:CLS
705 IF EF=2 THEN S1=1:S2=0:P2=Y-DP
790 GOTO 30
800 VIEW SCREEN(0,0)-(319,199):CLS
801 IF I1=0 THEN COLOR 2:PRINT "BAD PROGRAM!":END
805 COLOR 1:LOCATE 1,18:PRINT "SHADING"
806 COLOR 2:LOCATE 3,2:PRINT "NAME"
807 LOCATE 3,14:PRINT "PRIMARY":LOCATE 3,30:PRINT "BRIGHTNESS"
808 LINE(0,9)-(319,120),3,B:LINE(100,9)-(100,120),3:LINE(230,9)-(230,120),3
809 COLOR 3
810 LOCATE 5,2:PRINT "SOFT BLUE":LOCATE 7,2:PRINT "ICE WATER":LOCATE 9,2:PRINT "DEEP PURPLE":LOCATE 11,2:PRINT "FIRE RED":LOCATE 13,2:PRINT "GRASS"
815 LOCATE 5,14:PRINT "BLUE":LOCATE 7,14:PRINT "CYAN":LOCATE 9,14:PRINT "MAGENTA":LOCATE 11,14:PRINT "RED":LOCATE 13,14:PRINT "GREEN"
820 LOCATE 5,30:PRINT "DRAK":LOCATE 7,30:PRINT "BRIGHT":LOCATE 9,30:PRINT "MID":LOCATE 11,30:PRINT "MID":LOCATE 13,30:PRINT "BRIGHT"
821 COLOR 1:LOCATE 5,37:PRINT "(1)":LOCATE 7,37:PRINT "(2)":LOCATE 9,37:PRINT "(3)":LOCATE 11,37:PRINT "(4)":LOCATE 13,37:PRINT "(5)"
825 COLOR 1:IF I1=1 THEN LOCATE 5,2:PRINT "SOFT BLUE" ELSE IF I1=3 THEN LOCATE 7,2:PRINT "ICE WATER" ELSE IF I1=5 THEN LOCATE 9,2:PRINT "DEEP PURPLE" ELSE IF I1=4 THEN LOCATE 11,2:PRINT "FIRE RED" ELSE LOCATE 13,2:PRINT "GRASS"
830 LINE(50,140)-(60,160),1,B:PAINT(55,145),1:LINE(60,140)-(70,160),2,B:PAINT(65,145),2:LINE(70,140)-(80,160),3,B:PAINT(75,145),3
835 LINE(30,130)-(300,170),3,B
840 COLOR 2:LOCATE 19,13:PRINT "SELECT SHADE BY PRESSING":LOCATE 20,16:PRINT "CORESPONDING NUMBER"
845 A$=INKEY$:IF A$="" THEN 845
850 IF A$="1" THEN I1=1:I2=9:I3=3:GOTO 880
855 IF A$="2" THEN I1=3:I2=11:I3=15:GOTO 880
860 IF A$="3" THEN I1=5:I2=13:I3=12:GOTO 880
865 IF A$="4" THEN I1=4:I2=12:I3=14:GOTO 880
870 IF A$="5" THEN I1=2:I2=10:I3=14:GOTO 880
875 GOTO 845
880 CLS:BEEP:VIEW SCREEN(115,50)-(205,115):GOTO 500
899 END
900 CLS:FOR A=1 TO 7.2 STEP .2
905 X1=160+50*COS(A):Y1=100+50*SIN(A)
906 X2=160+50*COS(A+1.8):Y2=100+50*SIN(A+1.8)
907 X3=160+50*COS(A+3.2):Y3=100+50*SIN(A+3.2)
908 X4=160+50*COS(A+4.9):Y4=100+50*SIN(A+4.9)
910 CLS:LINE(X1,Y1)-(X2,Y2),2:LINE(X2,Y2)-(X3,Y3),2:LINE(X3,Y3)-(X4,Y4),2:LINE(X4,Y4)-(X1,Y1),1
911 GOTO 555
915 NEXT
920 GOTO 900