Data commit

Task/Pentagram/Action-/pentagram.action

@@ -0,0 +1,184 @@
+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