Curve that touches three points: Difference between revisions

Content added Content deleted

Inline

@@ Line 5: / Line 5: @@
 ::# &nbsp;Do not use functions of a library, implement the curve() function yourself
 ::# &nbsp;coordinates:(x,y) starting point (10,10) medium point (100,200) final point (200,10)
+=={{header|Action!}}==
+{{libheader|Action! Tool Kit}}
+<lang Action!>INCLUDE "D2:REAL.ACT" ;from the Action! Tool Kit
+TYPE Point=[INT x,y]
+PROC MyIntToReal(INT a REAL POINTER r)
+  BYTE ARRAY x
+  IF a>=0 THEN
+    IntToReal(a,r)
+  ELSE
+    IntToReal(-a,r)
+    x=r
+    x(0)==%$80
+  FI
+RETURN
+INT FUNC MyRealToInt(REAL POINTER r)
+  BYTE ARRAY x
+  REAL tmp
+  INT i
+  x=r
+  IF (x(0)&$80)=0 THEN
+    i=RealToInt(r)
+  ELSE
+    RealAssign(r,tmp)
+    x=tmp
+    x(0)==&$7F
+    i=-RealToInt(tmp)
+  FI
+RETURN (i)
+BYTE FUNC IsNegative(REAL POINTER r)
+  BYTE ARRAY x
+  x=r
+  IF (x(0)&$80)=$80 THEN
+    RETURN (1)
+  FI
+RETURN (0)
+PROC QuadraticCurve(Point POINTER p1,p2,p3 REAL POINTER a,b,c)
+  REAL x1,y1,x2,y2,x3,y3,x11,x22,x33,m,n,tmp1,tmp2,tmp3,tmp4,r1
+  MyIntToReal(-1,r1)
+  MyIntToReal(p1.x,x1) MyIntToReal(p1.y,y1)
+  MyIntToReal(p2.x,x2) MyIntToReal(p2.y,y2)
+  MyIntToReal(p3.x,x3) MyIntToReal(p3.y,y3)
+  RealMult(x1,x1,x11) ;x11=x1^2
+  RealMult(x2,x2,x22) ;x22=x2^2
+  RealMult(x3,x3,x33) ;x33=x3^2
+  RealSub(x1,x2,m)   ;m=x1-x2
+  RealSub(x3,x2,n)   ;n=x3-x2
+  RealMult(m,n,tmp1) ;tmp1=m*n
+  IF IsNegative(tmp1) THEN
+    RealMult(m,r1,tmp1)
+    RealAssign(tmp1,m)  ;m=-m
+  FI
+  RealSub(y1,y2,tmp1)     ;tmp1=y1-y2
+  RealMult(n,tmp1,tmp2)   ;tmp2=n*(y1-y2)
+  RealSub(y3,y2,tmp1)     ;tmp1=y3-y2
+  RealMult(m,tmp1,tmp3)   ;tmp3=m*(y3-y2)
+  RealAdd(tmp2,tmp3,tmp1) ;tmp1=n*(y1-y2)+m*(y3-y2)
+  RealSub(x11,x22,tmp2)   ;tmp2=x1^2-x2^2
+  RealMult(n,tmp2,tmp3)   ;tmp3=n*(x1^2-x2^2)
+  RealSub(x33,x22,tmp2)   ;tmp2=x3^2-x2^2
+  RealMult(m,tmp2,tmp4)   ;tmp4=m*(x3^2-x2^2)
+  RealAdd(tmp3,tmp4,tmp2) ;tmp2=n*(x1^2-x2^2)+m*(x3^2-x2^2)
+  RealDiv(tmp1,tmp2,a)    ;a=(n*(y1-y2)+m*(y3-y2)) / (n*(x1^2-x2^2)+m*(x3^2-x2^2))
+  RealSub(x33,x22,tmp1)   ;tmp1=x3^2-x2^2
+  RealMult(tmp1,a,tmp2)   ;tmp2=(x3^2-x2^2)*a
+  RealSub(y3,y2,tmp1)     ;tmp1=y3-y2
+  RealSub(tmp1,tmp2,tmp3) ;tmp3=(y3-y2)-(x3^2-x2^2)*a
+  RealSub(x3,x2,tmp1)     ;tmp1=x3-x2
+  RealDiv(tmp3,tmp1,b)    ;b=((y3-y2)-(x3^2-x2^2)*a) / (x3-x2)
+  RealMult(a,x11,tmp1)    ;tmp1=a*x1^2
+  RealMult(b,x1,tmp2)     ;tmp2=b*x1
+  RealSub(y1,tmp1,tmp3)   ;tmp3=y1-a*x1^2
+  RealSub(tmp3,tmp2,c)    ;c=y1-a*x1^2-b*x1
+RETURN
+PROC DrawPoint(INT x,y)
+  Plot(x-2,y-2) DrawTo(x+2,y-2)
+  DrawTo(x+2,y+2) DrawTo(x-2,y+2)
+  DrawTo(x-2,y-2)
+RETURN
+INT FUNC Min(INT a,b)
+  IF a<b THEN RETURN (a) FI
+RETURN (b)
+INT FUNC Max(INT a,b)
+  IF a>b THEN RETURN (a) FI
+RETURN (b)
+INT FUNC CalcY(REAL POINTER a,b,c INT xi)
+  REAL xr,xr2,yr,tmp1,tmp2,tmp3
+  INT yi
+  MyIntToReal(xi,xr)      ;xr=x
+  RealMult(xr,xr,xr2)     ;xr2=x^2
+  RealMult(a,xr2,tmp1)    ;tmp1=a*x^2
+  RealMult(b,xr,tmp2)     ;tmp2=b*x
+  RealAdd(tmp1,tmp2,tmp3) ;tmp3=a*x^2+b*x
+  RealAdd(tmp3,c,yr)      ;y3=a*x^2+b*x+c
+  yi=MyRealToInt(yr)
+RETURN (yi)
+PROC DrawCurve(Point POINTER p1,p2,p3)
+  REAL a,b,c
+  INT xi,yi,minX,maxX
+  QuadraticCurve(p1,p2,p3,a,b,c)
+  DrawPoint(p1.x,p1.y)
+  DrawPoint(p2.x,p2.y)
+  DrawPoint(p3.x,p3.y)
+  minX=Min(p1.x,p2.x)
+  minX=Min(minX,p3.x)
+  maxX=Max(p1.x,p2.x)
+  maxX=Max(maxX,p3.x)
+  yi=CalcY(a,b,c,minX)
+  Plot(minX,yi)
+  FOR xi=minX TO maxX
+  DO
+    yi=CalcY(a,b,c,xi)
+    DrawTo(xi,yi)
+  OD
+RETURN
+PROC Main()
+  BYTE CH=$02FC,COLOR1=$02C5,COLOR2=$02C6
+  Point p1,p2,p3
+  Graphics(8+16)
+  Color=1
+  COLOR1=$0C
+  COLOR2=$02
+  p1.x=10 p1.y=10
+  p2.x=100 p2.y=180
+  p3.x=200 p3.y=10
+  DrawCurve(p1,p2,p3)
+  DO UNTIL CH#$FF OD
+  CH=$FF
+RETURN</lang>
+{{out}}
+[https://gitlab.com/amarok8bit/action-rosetta-code/-/raw/master/images/Curve_that_touches_three_points.png Screenshot from Atari 8-bit computer]
 =={{header|Ada}}==