Anonymous user
Pentagram: Difference between revisions
Added solution for Action!
m (→{{header|Phix}}: added syntax colouring, marked p2js compatible) |
(Added solution for Action!) |
||
Line 12:
* [http://proofsfromthebook.com/2013/08/04/angle-sum-of-a-pentagram/ Angle sum of a pentagram]
<br><br>
=={{header|Action!}}==
{{libheader|Action! Tool Kit}}
<lang Action!>INCLUDE "D2:REAL.ACT" ;from the Action! Tool Kit
DEFINE REALPTR="CARD"
TYPE PointR=[REALPTR x,y]
INT ARRAY SinTab=[
0 4 9 13 18 22 27 31 36 40 44 49 53 58 62 66 71 75 79 83
88 92 96 100 104 108 112 116 120 124 128 132 136 139 143
147 150 154 158 161 165 168 171 175 178 181 184 187 190
193 196 199 202 204 207 210 212 215 217 219 222 224 226
228 230 232 234 236 237 239 241 242 243 245 246 247 248
249 250 251 252 253 254 254 255 255 255 256 256 256 256]
INT FUNC Sin(INT a)
WHILE a<0 DO a==+360 OD
WHILE a>360 DO a==-360 OD
IF a<=90 THEN
RETURN (SinTab(a))
ELSEIF a<=180 THEN
RETURN (SinTab(180-a))
ELSEIF a<=270 THEN
RETURN (-SinTab(a-180))
ELSE
RETURN (-SinTab(360-a))
FI
RETURN (0)
INT FUNC Cos(INT a)
RETURN (Sin(a-90))
PROC Det(REAL POINTER x1,y1,x2,y2,res)
REAL tmp1,tmp2
RealMult(x1,y2,tmp1)
RealMult(y1,x2,tmp2)
RealSub(tmp1,tmp2,res)
RETURN
BYTE FUNC IsZero(REAL POINTER a)
CHAR ARRAY s(10)
StrR(a,s)
IF s(0)=1 AND s(1)='0 THEN
RETURN (1)
FI
RETURN (0)
BYTE FUNC Intersection(PointR POINTER p1,p2,p3,p4,res)
REAL det1,det2,dx1,dx2,dy1,dy2,nom,denom
Det(p1.x,p1.y,p2.x,p2.y,det1)
Det(p3.x,p3.y,p4.x,p4.y,det2)
RealSub(p1.x,p2.x,dx1)
RealSub(p1.y,p2.y,dy1)
RealSub(p3.x,p4.x,dx2)
RealSub(p3.y,p4.y,dy2)
Det(dx1,dy1,dx2,dy2,denom)
IF IsZero(denom) THEN
RETURN (0)
FI
Det(det1,dx1,det2,dx2,nom)
RealDiv(nom,denom,res.x)
Det(det1,dy1,det2,dy2,nom)
RealDiv(nom,denom,res.y)
RETURN (1)
PROC FloodFill(BYTE x0,y0)
BYTE ARRAY xs(300),ys(300)
INT first,last
first=0 last=0
xs(first)=x0
ys(first)=y0
WHILE first<=last
DO
x0=xs(first) y0=ys(first)
first==+1
IF Locate(x0,y0)=0 THEN
Plot(x0,y0)
IF Locate(x0-1,y0)=0 THEN
last==+1 xs(last)=x0-1 ys(last)=y0
FI
IF Locate(x0+1,y0)=0 THEN
last==+1 xs(last)=x0+1 ys(last)=y0
FI
IF Locate(x0,y0-1)=0 THEN
last==+1 xs(last)=x0 ys(last)=y0-1
FI
IF Locate(x0,y0+1)=0 THEN
last==+1 xs(last)=x0 ys(last)=y0+1
FI
FI
OD
RETURN
PROC Pentagram(INT x0,y0,r,a0 BYTE c1,c2)
INT ARRAY xs(16),ys(16)
INT angle
BYTE i
PointR p1,p2,p3,p4,p
REAL p1x,p1y,p2x,p2y,p3x,p3y,p4x,p4y,px,py
p1.x=p1x p1.y=p1y
p2.x=p2x p2.y=p2y
p3.x=p3x p3.y=p3y
p4.x=p4x p4.y=p4y
p.x=px p.y=py
;outer points
angle=a0
FOR i=0 TO 4
DO
xs(i)=r*Sin(angle)/256+x0
ys(i)=r*Cos(angle)/256+y0
angle==+144
OD
;intersection points
FOR i=0 TO 4
DO
IntToReal(xs(i MOD 5),p1x)
IntToReal(ys(i MOD 5),p1y)
IntToReal(xs((1+i) MOD 5),p2x)
IntToReal(ys((1+i) MOD 5),p2y)
IntToReal(xs((2+i) MOD 5),p3x)
IntToReal(ys((2+i) MOD 5),p3y)
IntToReal(xs((3+i) MOD 5),p4x)
IntToReal(ys((3+i) MOD 5),p4y)
Intersection(p1,p2,p3,p4,p)
xs(5+i)=RealToInt(px)
ys(5+i)=RealToInt(py)
OD
;centers of triangles
FOR i=0 TO 4
DO
xs(10+i)=(xs(i)+xs(5+i)+xs(5+(i+2) MOD 5))/3
ys(10+i)=(ys(i)+ys(5+i)+ys(5+(i+2) MOD 5))/3
OD
;center of pentagon
xs(15)=0 ys(15)=0
FOR i=5 TO 9
DO
xs(15)==+xs(i)
ys(15)==+ys(i)
OD
xs(15)==/5 ys(15)==/5
;draw lines
COLOR=c1
FOR i=0 TO 5
DO
IF i=0 THEN
Plot(xs(i MOD 5),ys(i MOD 5))
ELSE
DrawTo(xs(i MOD 5),ys(i MOD 5))
FI
OD
;fill
COLOR=c2
FOR i=10 TO 15
DO
FloodFill(xs(i),ys(i))
OD
RETURN
PROC Main()
BYTE CH=$02FC
Graphics(7+16)
SetColor(0,8,4)
SetColor(1,8,8)
SetColor(2,8,12)
Pentagram(40,48,40,0,1,2)
Pentagram(119,48,40,15,2,3)
DO UNTIL CH#$FF OD
CH=$FF
RETURN</lang>
{{out}}
[https://gitlab.com/amarok8bit/action-rosetta-code/-/raw/master/images/Pentagram.png Screenshot from Atari 8-bit computer]
=={{header|Ada}}==
| |||