' Testroutine fuer die Schnittpunktberechnung

DEFDBL a-z
DIM SHARED Pi,RuFe,LTol,LTol2
Pi=4#*ATN(1#)
RuFe=.00015#
LTol=RuFe*640#
LTol2=LTol*LTol

SCREEN 1,640,512,2,4
WINDOW 2,"Schnittpunkt komplett",,0,1
COLOR ,1:CLS
FOR y%=0 TO 500 STEP 20
  FOR x%=0 TO 620 STEP 20
    PSET (x%,y%),0
  NEXT x%
NEXT y%

DIM x1(29),y1(29),r2(29),x2.sw(29),y2.ew(29),xs(1),ys(1)
t$="":n%=0
WHILE t$<>"F"
  LOCATE 1,1
  COLOR 2:PRINT "L";
  COLOR 3:PRINT "inie ";
  COLOR 2:PRINT "B";
  COLOR 3:PRINT "ogen ";
  COLOR 2:PRINT "F";
  COLOR 3:PRINT "ertig"
  t$=""
  WHILE t$=""
    t$=UCASE$(INKEY$)
  WEND
  LOCATE 1,1
  PRINT SPACE$(80)
  IF t$="L" THEN
    VerlangePunkt "Bitte Startpunkt eingeben",x1(n%),y1(n%)
    VerlangePunkt "Bitte Endpunkt eingeben",x2.sw(n%),y2.ew(n%)
    r2(n%)=-1#
    LINE (x1(n%),-y1(n%))-(x2.sw(n%),-y2.ew(n%)),0
    n%=n%+1
  ELSEIF t$="B" THEN
    VerlangePunkt "Bitte Mittelpunkt eingeben",x1(n%),y1(n%)
    VerlangePunkt "Bitte Startpunkt (gleichzeitig Durchgangspunkt) eingeben",xs,ys
    BestimmePolarwinkel x1(n%),y1(n%),xs,ys,x2.sw(n%)
    dx=xs-x1(n%)
    dy=ys-y1(n%)
    r2(n%)=dx*dx+dy*dy
    VerlangePunkt "Bitte Endpunkt (nur auf Radiusstrahl liegend) eingeben",xe,ye
    BestimmePolarwinkel x1(n%),y1(n%),xe,ye,y2.ew(n%)
    CIRCLE (x1(n%),-y1(n%)),SQR(r2(n%)),0,x2.sw(n%),y2.ew(n%),1!
    n%=n%+1
  END IF
WEND

g%=0
FOR i%=0 TO n%-2
  FOR j%=i%+1 TO n%-1
    e1%=r2(i%)=-1#
    e2%=r2(j%)=-1#
    IF e1% AND e2% THEN
      BestimmeSchnittpunktLinieLinie x1(i%),y1(i%),x2.sw(i%),y2.ew(i%),x1(j%),y1(j%),x2.sw(j%),y2.ew(j%),xs(0),ys(0),f%
    ELSEIF NOT e1% AND e2% THEN
      BestimmeSchnittpunktLinieKreis x1(j%),y1(j%),x2.sw(j%),y2.ew(j%),x1(i%),y1(i%),r2(i%),xs(0),ys(0),xs(1),ys(1),f%
    ELSEIF e1% AND NOT e2% THEN
      BestimmeSchnittpunktLinieKreis x1(i%),y1(i%),x2.sw(i%),y2.ew(i%),x1(j%),y1(j%),r2(j%),xs(0),ys(0),xs(1),ys(1),f%
    ELSE
      BestimmeSchnittpunktKreisKreis x1(i%),y1(i%),r2(i%),x1(j%),y1(j%),r2(j%),xs(0),ys(0),xs(1),ys(1),f%
    END IF
    IF e1% AND e2% THEN
      Ta%=0
      Az%=1+f%
    ELSE
      Ta%=f%=1
      Az%=2-f%+3*(f%=-1)
    END IF
    g%=g%+Az%
    FOR k%=0 TO Az%-1
      IF NOT Ta% THEN
        IF e1% THEN
          PruefeRealImaginaerLinie x1(i%),y1(i%),x2.sw(i%),y2.ew(i%),xs(k%),ys(k%),t1%
        ELSE
          PruefeRealImaginaerBogen x1(i%),y1(i%),SQR(r2(i%)),x2.sw(i%),y2.ew(i%),xs(k%),ys(k%),t1%
        END IF
        IF e2% THEN
          PruefeRealImaginaerLinie x1(j%),y1(j%),x2.sw(j%),y2.ew(j%),xs(k%),ys(k%),t2%
        ELSE
          PruefeRealImaginaerBogen x1(j%),y1(j%),SQR(r2(j%)),x2.sw(j%),y2.ew(j%),xs(k%),ys(k%),t2%
        END IF
        IF t1% AND t2% THEN
          ZeichneKreuz xs(k%),ys(k%),3
        ELSE
          ZeichneKreuz xs(k%),ys(k%),0
        END IF
      ELSE
        ZeichneKreuz xs(k%),ys(k%),2
      END IF
    NEXT k%
  NEXT j%
NEXT i%
LOCATE 1,1
PRINT "Total";g%;"Schnittpunkte gefunden"
WHILE MOUSE(0)>-1
WEND
WINDOW CLOSE 2
SCREEN CLOSE 1
END

SUB VerlangePunkt (k$,x,y) STATIC
  LOCATE 1,1:COLOR 2,1:PRINT k$
  WHILE MOUSE(0)>-1
  WEND
  LOCATE 1,1:PRINT SPACE$(80)
  x%=MOUSE(1)-1:y%=MOUSE(2)
  x=20#*INT(CDBL(x%)/20#+.5#)
  y=-(20#*INT(CDBL(y%)/20#+.5#))
  PSET (x,-y),2
  WHILE MOUSE(0)<0
  WEND
END SUB

SUB ZeichneKreuz (x,y,f%) STATIC
  LINE (x,3#-y)-STEP(0,-6),f%
  LINE STEP(-3,3)-STEP(6,0),f%
END SUB

SUB BestimmeSchnittpunktLinieLinie (x1,y1,x2,y2,x3,y3,x4,y4,xs,ys,f%) STATIC
  IF x1=x2 THEN
    xh1=x1:yh1=y1
    xh2=x3:yh2=y3
    dx1=0#:dy1=y2-y1
    dx2=x4-x3:dy2=y4-y3
  ELSE
    xh1=x3:yh1=y3
    xh2=x1:yh2=y1
    dx1=x4-x3:dy1=y4-y3
    dx2=x2-x1:dy2=y2-y1
  END IF
  IF dx1=0# THEN
    f%=dx2=0#
    IF NOT f% THEN
      xs=xh1
      ys=yh2+(xs-xh2)*dy2/dx2
    END IF
  ELSE
    s1=dy1/dx1
    s2=dy2/dx2
    f%=ABS(s1-s2)<=(1#+s1*s2)*RuFe
    IF NOT f% THEN
      yh3=yh1-s1*xh1
      yh4=yh2-s2*xh2
      xs=(yh4-yh3)/(s1-s2)
      ys=yh3+s1*xs
    END IF
  END IF
END SUB

SUB BestimmeSchnittpunktLinieKreis (x1,y1,x2,y2,x,y,r2,xs1,ys1,xs2,ys2,f%) STATIC
  BestimmeLinieLotfusspunkt x1,y1,x2,y2,x,y,xl,yl
  dx=xl-x
  dy=yl-y
  a2=dx*dx+dy*dy
  f%=a2>r2
  IF ABS(r2-a2)<=2#*LTol*SQR(r2) THEN
    f%=1
    xs1=xl
    ys1=yl
  ELSEIF NOT f% THEN
    b=SQR(r2-a2)
    dx=x2-x1
    dy=y2-y1
    a2=dx*dx+dy*dy
    a=SQR(a2)
    xb=b*dx/a
    yb=b*dy/a
    xs1=xl+xb
    ys1=yl+yb
    xs2=xl-xb
    ys2=yl-yb
  END IF
END SUB

SUB BestimmeSchnittpunktKreisKreis (x1,y1,r12,x2,y2,r22,xs1,ys1,xs2,ys2,f%) STATIC
  dx=x2-x1
  dy=y2-y1
  a2=dx*dx+dy*dy
  f%=a2<=LTol2
  IF NOT f% THEN
    a=SQR(a2)
    y=(a2+r12-r22)/2#/a
    xk=dx/a
    yk=dy/a
    xh=x1+xk*y
    yh=y1+yk*y
    b2=r12-y*y
    f%=b2<0#
    IF ABS(b2)<=2#*r1*RuFe THEN
      xs1=xh
      ys1=yh
      f%=1
    ELSEIF NOT f% THEN
      b=SQR(b2)
      xl=xk*b
      yl=yk*b
      xs1=xh-yl
      ys1=yh+xl
      xs2=xh+yl
      ys2=yh-xl
    END IF
  END IF
END SUB

SUB BestimmeLinieLotfusspunkt(x1,y1,x2,y2,xp,yp,xl,yl) STATIC
  dx=x2-x1
  dy=y2-y1
  IF dx=0# THEN
    xl=x1
    yl=yp
  ELSEIF dy=0# THEN
    xl=xp
    yl=y1
  ELSE
    S=dy/dx
    p=-dx/dy
    xl=(y1-x1*S-yp+xp*p)/(p-S)
    yl=(x1+y1*p-xp-yp*S)/(p-S)
  END IF
END SUB

SUB PruefeRealImaginaerLinie (x1,y1,x2,y2,x,y,t%) STATIC
  IF ABS(x2-x1)>ABS(y2-y1) THEN
    IF x2>x1 THEN
      t%=x>=x1-LTol AND x<=x2+LTol
    ELSE
      t%=x>=x2-LTol AND x<=x1+LTol
    END IF
  ELSE
    IF y2>y1 THEN
      t%=y>=y1-LTol AND y<=y2+LTol
    ELSE
      t%=y>=y2-LTol AND y<=y1+LTol
    END IF
  END IF
END SUB

SUB PruefeRealImaginaerBogen (xm,ym,r,sw,ew,x,y,t%) STATIC
  BestimmePolarwinkel xm,ym,x,y,w
  h=LTol/r
  IF ew>sw THEN
    t%=w>sw-h AND w<ew+h
  ELSE
    t%=w>sw-h OR w<ew+h
  END IF
END SUB

SUB BestimmePolarwinkel (xm,ym,x,y,w) STATIC
  dx=x-xm
  dy=y-ym
  IF dx=0# THEN 
    IF dy<0# THEN
      w=1.5#*Pi
    ELSE
      w=Pi/2#
    END IF
  ELSE
    IF dx<0# THEN
      h=1#
    ELSE
      IF dy<0# THEN
        h=2#
      ELSE
        h=0#
      END IF
    END IF
    w=ATN(dy/dx)+Pi*h
  END IF
END SUB