home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 1 / GoldFishApril1994_CD2.img / d4xx / d474 / aequipot / aequipotn.p < prev    next >
Text File  |  1991-04-17  |  26KB  |  852 lines
  1. {-------------------------------------------------------------------------}
  2.  
  3. PROGRAM Aequipotential;
  4.  
  5. {--------------------------------------------------------------------------
  6.  
  7.                        Aequipotential V1.06 NTSC
  8.                  written by J.Matern December 23, 1990
  9.                     last changed March 6, 1991
  10.                          written in PCQ-Pascal
  11.                       Compiler:PCQ-Compiler V1.1c
  12.                                   //
  13.                 Written for the \X/ Amiga; tested on a
  14.                     PAL Amiga 2000, Rev4.1; KickV1.2
  15.  
  16.                   Thanx to my brother Markus who gave
  17.                      me help and some good ideas!
  18.  
  19. --------------------------------------------------------------------------}
  20.  
  21. {$I "Include:Ports.i"       : GetMsg, ReplyMsg, WaitPort }
  22. {$I "Include:Intuition.i"   : AutoRequest, CloseScreen, CloseWindow,
  23.                               ModifyIDCMP, OpenScreen, OpenWindow,
  24.                               ScreenToBack, ScreenToFront, ShowTitle,
  25.                               ViewPortAddress }
  26. {$I "Include:Graphics.i"    : Draw, Move, RectFill, SetAPen,
  27.                               SetDrMd, SetRGB4, WritePixel }
  28. {$I "Include:Exec.i"        : CloseLibrary, Forbid, OpenLibrary, Permit }
  29. {$I "Include:Screen.i"      : Screen-Record Definition }
  30. {$I "Include:MathTrans.i"   : OpenMathTrans, CloseMathTrans, SPPow, SPSqrt }
  31. {$I "Include:Text.i"        : GText }
  32. {$I "Include:StringLib.i"   : AllocString, IntToString, stricmp, strcpy }
  33. {$I "Include:Parameters.i"  : GetParam, GetStartupMsg }
  34.  
  35. {-------------------------------------------------------------------------}
  36.  
  37. CONST
  38.         Ko        = 80.00;
  39.         MaxPot    = 15.00;
  40.         MaxLad    = 20;
  41.        {Skonst    = 256;      PAL  }
  42.         Skonst    = 200;    { NTSC }
  43.         RMBTRAP_f = $10000; {fehlt in Intuition.i}
  44.  
  45. {-------------------------------------------------------------------------}
  46.  
  47. VAR
  48.    Mathtest, NoHide     : BOOLEAN;
  49.    MovedMouse, Quit     : BOOLEAN;
  50.    Area, UpperLeft      : BOOLEAN;
  51.    Rect, ReqFlag        : BOOLEAN;
  52.    x,y,xf,yf,xs,ys      : INTEGER;
  53.    i,t,Fast,Leave       : INTEGER;
  54.    Anzahl,Modeflag      : INTEGER;
  55.    Whoehe,Wbreite       : INTEGER;
  56.    Shoehe,Sbreite,Smode : INTEGER;
  57.    Minho,Minbr,Atf      : INTEGER;
  58.    strlaeng             : INTEGER;
  59.    LeftX, LeftY,
  60.    RightX, RightY       : INTEGER;
  61.    Dummy                : INTEGER;
  62.    EPottest,Fak,Dist    : REAL;
  63.    xkord, ykord, empty  : STRING;
  64.    GrMode, SpMode       : STRING;
  65.    Rpktx,Rpkty          : ARRAY [0..4] OF INTEGER;
  66.    Apktx,Apkty          : ARRAY [0..8] OF INTEGER;
  67.    Arbfeld,Arbb,Arbh    : ARRAY [0..8] OF INTEGER;
  68.    Lad,Ladx,Lady        : ARRAY [0..MaxLad] OF REAL;
  69.    Pottest              : ARRAY [0..4] OF REAL;
  70.  
  71.    s        : ScreenPtr;
  72.    bw ,qw   : WindowPtr;
  73.    rp       : RastPortPtr;
  74.    m        : MessagePtr;
  75.    vp       : Address;
  76.    IM       : IntuiMessagePtr;
  77.    StoreMsg : IntuiMessage;
  78.    WBSP     : WBStartupPtr;
  79.    OK,
  80.    Cancel,
  81.    Repair,
  82.    Feintxt  : IntuiTextPtr;
  83.  
  84. {-------------------------------------------------------------------------}
  85.  
  86. FUNCTION OpenMyScreen : BOOLEAN;
  87. VAR
  88. ns : NewScreenPtr;
  89. BEGIN {OpenMyScreen}
  90.    new(ns);
  91.    WITH ns^ DO BEGIN
  92.       LeftEdge  := 0;
  93.       TopEdge   := 0;
  94.       Width     := Sbreite;
  95.       Height    := Shoehe;
  96.       Depth     := 3+ModeFlag;
  97.       DetailPen := TRUNC(16.0/Fak);
  98.       BlockPen  := 0;
  99.       ViewModes := Smode;
  100.       SType     := CUSTOMSCREEN_f;
  101.       Font      := nil;
  102.       DefaultTitle := "AequipotV1.06 © 1990/91 by J.Matern";
  103.       Gadgets   := nil;
  104.       CustomBitMap := nil;
  105.    END;
  106.    s := OpenScreen(ns);
  107.    dispose(ns);
  108.    OpenMyScreen := s <> nil;
  109. END; {OpenMyScreen}
  110.  
  111. {-------------------------------------------------------------------------}
  112.  
  113. FUNCTION OpenBackWindow : BOOLEAN;
  114. VAR
  115. nw : NewWindowPtr;
  116. BEGIN {OpenBackWindow}
  117.    new(nw);
  118.    WITH nw^ DO BEGIN
  119.       LeftEdge  := 0;
  120.       TopEdge   := 0;
  121.       Width     := Wbreite;
  122.       Height    := Whoehe;
  123.       DetailPen := -1;
  124.       BlockPen  := -1;
  125.       IDCMPFlags := MOUSEBUTTONS_f;
  126.       Flags := BACKDROP_f + BORDERLESS_f + SMART_REFRESH_f + ACTIVATE_f +
  127.                REPORTMOUSE_f + RMBTRAP_f;
  128.       FirstGadget := nil;
  129.       CheckMark := nil;
  130.       Title     := nil;   {kein Titel, da in ganzem Window gezeichnet wird}
  131.       Screen    := s;
  132.       BitMap    := nil;
  133.       MinWidth  := 50;
  134.       MaxWidth  := -1;
  135.       MinHeight := 20;
  136.       MaxHeight := -1;
  137.       WType := CUSTOMSCREEN_f;
  138.    END;
  139.    bw := OpenWindow(nw);
  140.    dispose(nw);
  141.    OpenBackWindow := bw <> nil;
  142. END; {OpenBackWindow}
  143.  
  144. {-------------------------------------------------------------------------}
  145.  
  146. PROCEDURE CloseAll;
  147. BEGIN
  148.    IF s <> nil THEN
  149.       ScreenToBack(s);
  150.  
  151.    IF bw <> nil THEN BEGIN
  152.       Forbid;
  153.       REPEAT
  154.          IM := IntuiMessagePtr(GetMsg(bw^.UserPort));
  155.          IF IM <> nil THEN ReplyMsg(MessagePtr(IM));
  156.       UNTIL IM = nil;
  157.       CloseWindow(bw);
  158.       Permit;
  159.    END;
  160.  
  161.    IF s <>nil THEN
  162.       CloseScreen(s);
  163.  
  164.    IF GfxBase <> nil THEN
  165.       CloseLibrary(GfxBase);
  166.  
  167.    IF Mathtest = TRUE THEN
  168.       CloseMathTrans;
  169.  
  170. END;
  171.  
  172. {-------------------------------------------------------------------------}
  173.  
  174. PROCEDURE OpenAll;
  175. BEGIN
  176.    GfxBase := OpenLibrary("graphics.library", 0);
  177.    IF GfxBase = nil THEN BEGIN
  178.       WRITELN('Could not open Graphics.library');
  179.          CloseAll;
  180.       EXIT(20);
  181.    END;
  182.  
  183.    Mathtest := OpenMathTrans();
  184.    IF (NOT Mathtest) THEN BEGIN
  185.       WRITELN('Could not open Mathtrans.library');
  186.          CloseAll;
  187.       EXIT(20);
  188.    END;
  189.  
  190.    IF (NOT OpenMyScreen) THEN BEGIN
  191.       writeln('Could not open the screen!');
  192.       CloseAll;
  193.       Exit(20);
  194.    END;
  195.    ShowTitle(s, FALSE);
  196.  
  197.    IF (NOT OpenBackWindow) THEN BEGIN
  198.       writeln('Could not open the window!');
  199.       CloseAll;
  200.       Exit(20);
  201.    END;
  202.    rp:=bw^.RPort;
  203.  
  204. END;
  205.  
  206. {-------------------------------------------------------------------------}
  207.  
  208. FUNCTION Distance(x,y : REAL; xx,yy : INTEGER) : REAL;
  209. {Entfernungsbestimmung mit Pythagoras zwischen (x,y) u. (xx,yy)}
  210. BEGIN
  211.    Distance:=SPsqrt(SQR(x-FLOAT(xx))+SQR(y-FLOAT(yy)));
  212.    {SPsqrt ist viel schneller als SQRT!!}
  213. END;
  214.  
  215. {-------------------------------------------------------------------------}
  216.  
  217. FUNCTION Potential(Lad,Dist : REAL) : REAL;
  218. {Potentialbestimmung zur Ladung (Lad) in Entfernung (Dist)}
  219. BEGIN
  220.    Potential:=Ko*(Lad/Dist);
  221. END;
  222.  
  223. {-------------------------------------------------------------------------}
  224.  
  225. PROCEDURE HandleMessage;
  226. BEGIN
  227.    IM := IntuiMessagePtr(WaitPort(bw^.UserPort));
  228.    IM := IntuiMessagePtr(GetMsg(bw^.UserPort));
  229.    StoreMsg := IM^;
  230.    ReplyMsg(MessagePtr(IM));
  231.    CASE StoreMsg.Class OF
  232.       MOUSEBUTTONS_f : BEGIN
  233.          IF StoreMsg.Code = SELECTUP THEN BEGIN
  234.             IF NoHide=TRUE THEN
  235.                NoHide:=FALSE
  236.             ELSE
  237.                NoHide:=TRUE;
  238.             ShowTitle(s, NoHide);
  239.          END;
  240.          IF StoreMsg.Code = MENUUP THEN BEGIN
  241.             Quit:=TRUE;
  242.          END;
  243.       END;
  244.    END;
  245. END;
  246.  
  247. {-------------------------------------------------------------------------}
  248.  
  249. PROCEDURE RechnePotential; {Potential an jedem der fünf Rechenpunkte wird
  250.                             berechnet=Pottest[0-4]}
  251. BEGIN
  252.    FOR t:=0 TO 4 DO BEGIN
  253.       Pottest[t]:=0.0;
  254.       FOR i:=1 TO Anzahl DO BEGIN
  255.          Dist:=Distance(Ladx[i],Lady[i],Rpktx[t],Rpkty[t]);
  256.          IF Dist<>0.0 THEN BEGIN
  257.             Pottest[t]:=Pottest[t]+Potential(Lad[i],Dist);
  258.          END ELSE
  259.             Pottest[t]:=100.0*Lad[i];
  260.       END;
  261.    END;
  262. END;
  263.  
  264. {-------------------------------------------------------------------------}
  265.  
  266. PROCEDURE Drawing(x,y : INTEGER); {Potential an x,y wird berechnet und
  267.                                    gezeichnet}
  268. BEGIN {Drawing}
  269.    EPottest:=0.0;
  270.    FOR i:=1 TO Anzahl DO BEGIN {Aufsummieren der Einzelpotentiale über
  271.                                 die verschiedenen Ladungen}
  272.       Dist:=Distance(Ladx[i],Lady[i],x,y);
  273.       IF Dist<>0.0 THEN BEGIN
  274.          EPottest:=EPottest+Potential(Lad[i],Dist);
  275.       END ELSE
  276.          Epottest:=100.0*Lad[i];
  277.    END;
  278.    IF ABS(EPottest)<MaxPot THEN BEGIN     {wenn Potential nicht zu groß}
  279.       SetAPen(rp,ROUND((EPottest+16.0)/Fak)); {dann Farbwahl und}
  280.       WritePixel(rp,x,y);                     {Setzen eines Punktes}
  281.    END;
  282. END; {Drawing}
  283.  
  284. {-------------------------------------------------------------------------}
  285.  
  286. PROCEDURE FastDraw(xsta, ysta, xe, ye, xste, yste : INTEGER; Modus : BOOLEAN);
  287.                         {Schneller Überblick über die Grafik}
  288.                         {oder Reperatur, je nach Modus}
  289. BEGIN {FastDraw}
  290.    y:=ysta;
  291.    REPEAT
  292.    {Schleife für y-Koordinate}
  293.       x:=xsta;
  294.       REPEAT
  295.       {Schleife für x-Koordinate}
  296.          EPottest:=0.0;
  297.          m:=GetMsg(bw^.UserPort);
  298.          IF m <> nil THEN BEGIN {Abbruch bei Mausknopf}
  299.             HandleMessage;
  300.             IF Quit=TRUE THEN BEGIN
  301.                x:=xe+1;
  302.                y:=ye+1;
  303.             END;
  304.          END;
  305.          FOR i:=1 TO Anzahl DO BEGIN    {Potential Aufsummieren}
  306.             Dist:=Distance(Ladx[i],Lady[i],x,y);
  307.             IF Dist<>0.0 THEN BEGIN
  308.                EPottest:=EPottest+Potential(Lad[i],Dist);
  309.             END ELSE
  310.                EPottest:=100.0*Lad[i];
  311.          END;
  312.          IF ABS(EPottest)<MaxPot THEN BEGIN {falls Potential nicht zu groß}
  313.             SetAPen(rp,ROUND((EPottest+16.0)/Fak)); {dann Farbwahl und}
  314.             IF Modus THEN
  315.                WritePixel(rp,x,y)                       {Punkt setzen}
  316.             ELSE                                        {oder}
  317.                RectFill(rp,x,y,x+xste,y+yste+1);        {Fläche füllen}
  318.          END;
  319.          x:=x+xste;
  320.       UNTIL x >= xe; {Schleifenende x}
  321.       y:=y+yste;
  322.    UNTIL y >= ye; {Schleifenende y}
  323. END; {FastDraw}
  324.  
  325. {-------------------------------------------------------------------------}
  326.  
  327. PROCEDURE Clear; {Window löschen}
  328. BEGIN
  329.    SetAPen(rp,0);
  330.    RectFill(rp,0,0,Sbreite,Shoehe);
  331.    SetAPen(rp,TRUNC(16.0/Fak));
  332. END;
  333.  
  334. {-------------------------------------------------------------------------}
  335.  
  336. PROCEDURE Cross(x,y : INTEGER); {Zeichnet Kreuz bei x,y}
  337. BEGIN
  338.    MOVE(rp,x-2,y);
  339.    DRAW(rp,x+2,y);
  340.    MOVE(rp,x,y-2);
  341.    DRAW(rp,x,y+2);
  342. END;
  343.  
  344. {-------------------------------------------------------------------------}
  345.  
  346. PROCEDURE LadMark; {Übergibt Koordinaten jeder Ladung an Cross}
  347. BEGIN
  348.    Clear;
  349.    FOR i:=1 TO Anzahl DO BEGIN
  350.       x:=TRUNC(Ladx[i]);
  351.       y:=TRUNC(Lady[i]);
  352.       Cross(x,y);
  353.    END;
  354. END;
  355.  
  356. {-------------------------------------------------------------------------}
  357.  
  358. PROCEDURE Color; {Farbpalette wird in Abhängigkeit von ScreenAuflösung
  359.                   gesetzt}
  360. BEGIN {Color}
  361.    vp:= ViewPortAddress(bw);
  362.    IF ModeFlag=2 THEN BEGIN
  363.       SetRGB4(vp, 0, 0, 0, 0);
  364.       FOR i:=1 TO 16 DO
  365.          SetRGB4(vp, i,15, i-1,0);
  366.       FOR i:=16 TO 31 DO
  367.          SetRGB4(vp, i,31-i,31-i,i-16);
  368.    END ELSE BEGIN
  369.       SetRGB4(vp, 0, 0, 0, 0);
  370.       FOR i:=1 TO 8 DO
  371.          SetRGB4(vp,i,15,i*2-1,0);
  372.       FOR i:=8 TO 15 DO
  373.          SetRGB4(vp, i,31-2*i,31-2*i,i*2-16);
  374.    END;
  375.    SetAPen(rp,TRUNC(16.0/Fak));
  376. END; {Color}
  377.  
  378. {-------------------------------------------------------------------------}
  379.  
  380. PROCEDURE Pointtest; {Berechnung von fünf Probekoordinaten in Abhängigkeit
  381.                       vom Arbeitspunkt; Berechnung des Potentials an den
  382.                       fünf Rechenpunkten; je nach Ergebnis Füllen der
  383.                       Fläche, Veränderung der Arbeitstiefe (Atf) und des
  384.                       Arbeitsbereichs}
  385. BEGIN {Pointtest}
  386.    Rpktx[0]:=Apktx[Atf]; {Berechnung der Probekoordinaten}
  387.    Rpkty[0]:=Apkty[Atf];
  388.    Rpktx[1]:=Apktx[Atf]+Arbb[Atf]-1;
  389.    Rpkty[1]:=Apkty[Atf];
  390.    Rpktx[2]:=Apktx[Atf];
  391.    Rpkty[2]:=Apkty[Atf]+Arbh[Atf]-1;
  392.    Rpktx[3]:=Apktx[Atf]+Arbb[Atf]-1;
  393.    Rpkty[3]:=Apkty[Atf]+Arbh[Atf]-1;
  394.    Rpktx[4]:=Apktx[Atf]+Arbb[Atf+1]-1;
  395.    Rpkty[4]:=Apkty[Atf]+Arbh[Atf+1]-1;
  396.    RechnePotential; {Berechnung des Potentials an den fünf Punkten}
  397.    IF (ROUND(Pottest[0]/Fak)=ROUND(Pottest[1]/Fak)) AND
  398.     (ROUND(Pottest[1]/Fak)=ROUND(Pottest[2]/Fak)) AND
  399.     (ROUND(Pottest[2]/Fak)=ROUND(Pottest[3]/Fak)) AND
  400.     (ROUND(Pottest[3]/Fak)=ROUND(Pottest[4]/Fak)) THEN BEGIN {Falls das
  401.                         Potential an allen fünf Punkten identisch ist}
  402.       IF ABS(Pottest[0])<MaxPot THEN BEGIN
  403.          SetAPen(rp,ROUND((Pottest[0]+16.0)/Fak)); {dann Farbauswahl und}
  404.          RectFill(rp,Rpktx[0],Rpkty[0],Rpktx[3],Rpkty[3]); {Füllen der
  405.                                           entsprechenden Fläche}
  406.       END;
  407. {*}   IF Arbfeld[Atf]=5 THEN BEGIN {Test, ob momentane Arbeitstiefe schon
  408.                           vollständig bearbeitet wurde}
  409.          REPEAT
  410.             Arbfeld[Atf]:=1;       {dann Arbeitstiefe verringern}
  411.             DEC(Atf);
  412.          UNTIL Arbfeld[Atf]<5;
  413.       END ELSE
  414.          INC(Arbfeld[Atf]); {sonst Arbeitsbereich erhöhen}
  415.    END ELSE BEGIN                 {wenn Fläche nicht gefüllt werden konnte,}
  416.       IF (Atf=8) THEN BEGIN       {maximale Arbeitstiefe erreicht ist}
  417.          IF (ABS(Pottest[0]/Fak)<Maxpot) OR
  418.           (ABS(Pottest[1]/Fak)<Maxpot) OR
  419.           (ABS(Pottest[2]/Fak)<Maxpot) OR
  420.           (ABS(Pottest[3]/Fak)<Maxpot) THEN BEGIN {und Fläche nicht schwarz}
  421.             FOR x:=Rpktx[0] TO Rpktx[3] DO BEGIN     {wird Fläche Pixel}
  422.                FOR y:=Rpkty[0] TO Rpkty[3] DO BEGIN  {für Pixel berechnet}
  423.                   Drawing(x,y);
  424.                END;
  425.             END;
  426.          END;
  427.          IF Arbfeld[Atf]=5 THEN BEGIN {siehe *}
  428.             REPEAT
  429.                Arbfeld[Atf]:=1;
  430.                DEC(Atf);
  431.             UNTIL Arbfeld[Atf]<5;
  432.          END ELSE
  433.             INC(Arbfeld[Atf]);
  434.       END ELSE BEGIN    {Fläche konnte nicht gefüllt werden, maximale
  435.                          Arbeitstiefe ist aber noch nicht erreicht}
  436.          IF Arbfeld[Atf]=5 THEN
  437.             Arbfeld[Atf]:=1
  438.          ELSE
  439.             INC(Arbfeld[Atf]);
  440.          INC(Atf);    {Arbeitstiefe erhöhen}
  441.       END;
  442.    END;
  443. END; {Pointtest}
  444.  
  445. {-------------------------------------------------------------------------}
  446.  
  447. PROCEDURE Areatest; {Test, in welchem der vier möglichen Arbeitsbereiche
  448.                      momentan gerade gerechnet wird und entsprechende Wahl
  449.                      des Arbeitpunktes (Apktx,Apkty) der momentanen
  450.                      Arbeitstiefe (Atf)}
  451. BEGIN {Areatest}
  452.    REPEAT
  453.       CASE Arbfeld[Atf] OF
  454.          1 : BEGIN  {Bereich 1=links oben}
  455.             xf:=0;
  456.             yf:=0;
  457.          END;
  458.          2 : BEGIN  {Bereich 2=rechts oben}
  459.             xf:=1;
  460.             yf:=0;
  461.          END;
  462.          3 : BEGIN  {Bereich 3=links unten}
  463.             xf:=0;
  464.             yf:=1;
  465.          END;
  466.          ELSE BEGIN {Bereich 4=rechts unten}
  467.             xf:=1;
  468.             yf:=1;
  469.          END;
  470.       END;
  471.       Apktx[Atf]:=Apktx[Atf-1]+xf*Arbb[Atf]; {Berechnung des neuen}
  472.       Apkty[Atf]:=Apkty[Atf-1]+yf*Arbh[Atf]; {Arbeitpunktes in Tiefe Atf}
  473.       Pointtest;
  474.       Leave:=Apktx[Atf]+Arbb[Atf];
  475.       m:=GetMsg(bw^.UserPort); {Test auf linke Maustaste}
  476.       IF m <> nil THEN BEGIN
  477.          HandleMessage;
  478.          IF Quit=TRUE THEN               {und verlassen zum Hauptprogramm}
  479.             Leave:=(640 DIV Modeflag)+1; {falls diese gedrückt wurde}
  480.       END;
  481.    UNTIL Leave>(640 DIV ModeFlag); {Test, ob der gesamte
  482.                                     Bildschirm bereits
  483.                                     berechnet wurde}
  484. END; {Areatest}
  485.  
  486. {-------------------------------------------------------------------------}
  487.  
  488. PROCEDURE LadKoord;
  489. BEGIN
  490.    ModifyIDCMP(bw, MOUSEBUTTONS_f + MOUSEMOVE_f);
  491.    Quit:=FALSE;
  492.    MovedMouse:=FALSE;
  493.    Anzahl:=0;
  494.    Move(rp,(Sbreite-296) DIV 2,Shoehe DIV 2);
  495.    GText(rp,"Press left mbutton to set powersource",37);
  496.    Move(rp,(Sbreite-240) DIV 2,(Shoehe DIV 2)+10);
  497.    GText(rp," press right mbutton to stop! ",30);
  498.    REPEAT
  499.       IM := IntuiMessagePtr(WaitPort(bw^.UserPort));
  500.       IM := IntuiMessagePtr(GetMsg(bw^.UserPort));
  501.       StoreMsg := IM^;
  502.       ReplyMsg(MessagePtr(IM));
  503.          CASE StoreMsg.Class OF
  504.          MOUSEMOVE_f : BEGIN
  505.             IF MovedMouse=FALSE THEN BEGIN
  506.                Clear;
  507.                MovedMouse:=TRUE;
  508.             END ELSE BEGIN
  509.                x:=StoreMsg.MouseX;
  510.                y:=StoreMsg.MouseY;
  511.                strlaeng:=IntToStr(xkord,x);
  512.                Move(rp,Sbreite-25,Shoehe-12);
  513.                Gtext(rp, empty, 3);
  514.                Move(rp,Sbreite-25,Shoehe-12);
  515.                Gtext(rp, xkord, strlaeng);
  516.                strlaeng:=IntToStr(ykord,y);
  517.                Move(rp,Sbreite-25,Shoehe-2);
  518.                Gtext(rp, empty, 3);
  519.                Move(rp,Sbreite-25,Shoehe-2);
  520.                Gtext(rp, ykord, strlaeng);
  521.             END;
  522.          END;
  523.          MOUSEBUTTONS_f : BEGIN
  524.             IF (StoreMsg.Code = SELECTUP) AND
  525.             (MovedMouse=TRUE) THEN BEGIN {linker Mausknopf}
  526.                INC(Anzahl);
  527.                x:=StoreMsg.MouseX;
  528.                y:=StoreMsg.MouseY;
  529.                Cross(x,y);
  530.                Ladx[Anzahl]:=FLOAT(x);
  531.                Lady[Anzahl]:=FLOAT(y);
  532.             END;
  533.             IF StoreMsg.Code = MENUUP THEN BEGIN   {rechter Mausknopf}
  534.                Quit:=TRUE;
  535.             END;
  536.          END;
  537.       END;
  538.    UNTIL ((Quit=TRUE) OR (Anzahl=MaxLad)) AND (Anzahl>0);
  539.    ModifyIDCMP(bw, MOUSEBUTTONS_f);
  540.    Quit:=FALSE;
  541. END;
  542.  
  543. {-------------------------------------------------------------------------}
  544.  
  545. PROCEDURE LadGet;
  546. BEGIN
  547.    ScreenToBack(s);
  548.    FOR t:=1 TO Anzahl DO BEGIN
  549.       WRITE('PowerSource ',t,' (',TRUNC(Ladx[t]),',',TRUNC(Lady[t]),'): ');
  550.       READLN(Lad[t]);
  551.    END;
  552.    ScreenToFront(s);
  553. END;
  554.  
  555. {-------------------------------------------------------------------------}
  556.  
  557. PROCEDURE Usage;
  558. BEGIN
  559.    WRITELN('Usage: AEQUIPOT ScreenMode RenderingMode');
  560.    WRITELN('       Where ScreenMode is h(igh) or l(ow)');
  561.    WRITELN('       and RenderingMode is s(low) or f(ast).');
  562.    WRITELN;
  563.    EXIT(20);
  564. END;
  565.  
  566. {-------------------------------------------------------------------------}
  567.  
  568. PROCEDURE RectArea;   {Zeichnet Rechteck (LeftX,LeftY/RightX,RightY)}
  569. BEGIN
  570.    Move(rp, LeftX, LeftY);
  571.    Draw(rp, RightX, LeftY);
  572.    Draw(rp, RightX, RightY);
  573.    Draw(rp, LeftX, RightY);
  574.    Draw(rp, LeftX, LeftY);
  575. END;
  576.  
  577. {-------------------------------------------------------------------------}
  578.  
  579. PROCEDURE SetRepArea;
  580. BEGIN
  581.    ModifyIDCMP(bw, MOUSEMOVE_f + MOUSEBUTTONS_f);
  582.    SetDrMd(rp, COMPLEMENT);
  583.    Rect:=FALSE;
  584.    UpperLeft:=FALSE;
  585.    Area:=FALSE;
  586.    REPEAT
  587.       IM := IntuiMessagePtr(WaitPort(bw^.UserPort));
  588.       IM := IntuiMessagePtr(GetMsg(bw^.UserPort));
  589.       StoreMsg := IM^;
  590.       ReplyMsg(MessagePtr(IM));
  591.          CASE StoreMsg.Class OF
  592.          MOUSEMOVE_f : BEGIN
  593.             IF UpperLeft=TRUE THEN BEGIN
  594.                RectArea;
  595.                RightX := (StoreMsg.MouseX DIV 5)*5+4;
  596.                RightY := (StoreMsg.MouseY DIV 4)*4+3;
  597.                RectArea;
  598.             END;
  599.          END;
  600.          MOUSEBUTTONS_f : BEGIN
  601.             IF (StoreMsg.Code = SELECTUP) THEN BEGIN    {linker Mausknopf}
  602.                IF UpperLeft THEN BEGIN                  {zum 2. mal}
  603.                   UpperLeft:=FALSE;
  604.                   RightX := (StoreMsg.MouseX DIV 5)*5+4;
  605.                   RightY := (StoreMsg.MouseY DIV 4)*4+3;
  606.                END ELSE BEGIN                           {zum 1. mal}
  607.                   IF Rect = TRUE THEN                   {wenn Umrandung da}
  608.                      RectArea;                          {diese löschen}
  609.                   UpperLeft := TRUE;
  610.                   Rect := TRUE;
  611.                   LeftX := (StoreMsg.MouseX DIV 5)*5;
  612.                   LeftY := (StoreMsg.MouseY DIV 4)*4;
  613.                   RightX := LeftX;
  614.                   RightY := LeftY;
  615.                   RectArea;
  616.                END;
  617.             END;
  618.             IF (StoreMsg.Code = MENUUP) AND
  619.              (UpperLeft = FALSE) AND
  620.              (Rect = TRUE) THEN BEGIN {rechter Mausknopf u. Bereich gewählt}
  621.                RectArea;
  622.                Area:=TRUE;
  623.             END;
  624.          END;
  625.       END;
  626.    UNTIL Area=TRUE;
  627.    ModifyIDCMP(bw, MOUSEBUTTONS_f);
  628.    SetDrMd(rp, JAM1);
  629. END;
  630.  
  631. {-------------------------------------------------------------------------}
  632.  
  633. PROCEDURE RepairArea; {reparieren der Grafik}
  634. BEGIN
  635.    IF RightX < LeftX THEN BEGIN
  636.       Dummy := LeftX;
  637.       LeftX := RightX;
  638.       RightX:= Dummy;
  639.    END;
  640.    IF RightY < LeftY THEN BEGIN
  641.       Dummy := LeftY;
  642.       LeftY := RightY;
  643.       RightY:= Dummy;
  644.    END;
  645.    FastDraw(LeftX,LeftY,RightX,RightY,1,1,TRUE);
  646. END;
  647.  
  648. {-------------------------------------------------------------------------}
  649.  
  650. PROCEDURE Parameter;
  651. BEGIN
  652.    GrMode := AllocString(10);
  653.    SPMode := AllocString(10);
  654.  
  655.    WBSP := GetStartupMsg();
  656.  
  657.    IF WBSP <> nil THEN BEGIN                  {WB-Start}
  658.       REPEAT
  659.          WRITE('Enter screenmode h(igh) oder l(ow): ');
  660.          READLN(GrMode);
  661.       UNTIL (stricmp(GrMode,"h")=0) OR (stricmp(GrMode,"l")=0);
  662.       REPEAT
  663.          WRITE('Enter renderingmode f(ast) oder s(low): ');
  664.          READLN(Spmode);
  665.       UNTIL (stricmp(SpMode,"f")=0) OR (stricmp(SpMode,"s")=0);
  666.    END ELSE BEGIN                             {CLI-Start}
  667.       GetParam(1, GrMode);
  668.       GetParam(2, SpMode);
  669.    END;
  670.  
  671.    IF (stricmp(GrMode,"h")=0) OR (stricmp(GrMode,"l")=0) THEN BEGIN
  672.       IF (stricmp(SpMode,"f")=0) OR (stricmp(SpMode,"s")=0) THEN BEGIN
  673.          IF stricmp(GrMode,"l")=0 THEN
  674.             Smode:=1
  675.          ELSE
  676.             Smode:=2;
  677.          IF stricmp(SpMode,"f")=0 THEN
  678.             Fast:=1
  679.          ELSE
  680.             Fast:=2;
  681.       END ELSE
  682.          Usage;
  683.    END ELSE
  684.        Usage;
  685. END;
  686.  
  687. {-------------------------------------------------------------------------}
  688.  
  689. PROCEDURE TextDef;
  690. BEGIN
  691.    NEW(OK);
  692.    WITH OK^ DO BEGIN
  693.       FrontPen    := TRUNC(16.0/Fak);
  694.       Backpen     := 0;
  695.       DrawMode    := JAM1;
  696.       KludgeFill  := 0; { Kludge is just a reminder here }
  697.       LeftEdge    := 6; { relative to gadget }
  698.       TopEdge     := 3; { -"- }
  699.       ITextFont   := nil;
  700.       IText       := "OK";
  701.       NextText    := nil;
  702.    END;
  703.    NEW(Cancel);
  704.    WITH Cancel^ DO BEGIN
  705.       FrontPen    := TRUNC(16.0/Fak);
  706.       Backpen     := 0;
  707.       DrawMode    := JAM1;
  708.       KludgeFill  := 0; { Kludge is just a reminder here }
  709.       LeftEdge    := 7; { relative to gadget }
  710.       TopEdge     := 3; { -"- }
  711.       ITextFont   := nil;
  712.       IText       := "Cancel";
  713.       NextText    := nil;
  714.    END;
  715.    NEW(Repair);
  716.    WITH Repair^ DO BEGIN
  717.       FrontPen    := TRUNC(16.0/Fak);
  718.       Backpen     := 0;
  719.       DrawMode    := JAM1;
  720.       KludgeFill  := 0; { Kludge is just a reminder here }
  721.       LeftEdge    := 16;{ relative to gadget }
  722.       TopEdge     := 8; { -"- }
  723.       ITextFont   := nil;
  724.       IText       := "Do you want to repair?";
  725.       NextText    := nil;
  726.    END;
  727.    NEW(Feintxt);
  728.    WITH Feintxt^ DO BEGIN
  729.       FrontPen    := TRUNC(16.0/Fak);
  730.       Backpen     := 0;
  731.       DrawMode    := JAM1;
  732.       KludgeFill  := 0; { Kludge is just a reminder here }
  733.       LeftEdge    := 16;{ relative to gadget }
  734.       TopEdge     := 8; { -"- }
  735.       ITextFont   := nil;
  736.       IText       := "Do you want to render slow?";
  737.       NextText    := nil;
  738.    END;
  739. END;
  740.  
  741. {-------------------------------------------------------------------------}
  742.  
  743. PROCEDURE Init; {Programmstart wird vorbereitet}
  744. BEGIN {Init}
  745.    WRITELN;
  746.    WRITELN('Aequipot V1.06 NTSC (March 6, 1991)');
  747.    WRITELN('Copyright © 1990/91 Juergen Matern. All rights reserved.');
  748.    WRITELN;
  749.  
  750.    Minbr:=5;
  751.    Minho:=4;
  752.    empty:="   ";
  753.  
  754.    Parameter;
  755.  
  756.    IF Smode=1 THEN BEGIN   {LoRes-Einstellungen}
  757.       Sbreite:=320;
  758.       Shoehe:=Skonst;
  759.       Wbreite:=320;
  760.       Whoehe:=Shoehe;
  761.       Smode:=16384;      {LoRes=16384}
  762.       ModeFlag:=2;
  763.       Atf:=2;
  764.    END ELSE BEGIN        {HiRes-Einstellungen}
  765.       Sbreite:=640;
  766.       Shoehe:=2*Skonst;
  767.       Wbreite:=640;
  768.       Whoehe:=Shoehe;
  769.       Smode:=32772;      {HiRes=32768 Lace=4}
  770.       ModeFlag:=1;
  771.       Atf:=1;
  772.    END;
  773.  
  774.    Fak:=(3.0-FLOAT(ModeFlag));
  775.    xs:=Minbr*(3-ModeFlag);
  776.    ys:=Minho*(3-ModeFlag);
  777.  
  778.    TextDef;
  779.  
  780.    Quit:=FALSE;
  781. END; {Init}
  782.  
  783. {-------------------------------------------------------------------------}
  784.  
  785. BEGIN {MAIN}
  786.    Init;
  787.    OpenAll;
  788.  
  789.    FOR t:=0 TO 8 DO BEGIN {t heißt eigentlich Atf, ist aber schon besetzt}
  790.       Arbb[t]:=TRUNC(FLOAT(Minbr)*SPPow(8.0-FLOAT(t),2.0)); {2^(8-t)}
  791.       Arbh[t]:=TRUNC(FLOAT(Minho)*SPPow(8.0-FLOAT(t),2.0));
  792.       Arbfeld[t]:=1;
  793.       Apktx[t]:=0;
  794.       Apkty[t]:=0;
  795.    END;                   {Gehoert eigentlich in Init; dort ist aber die
  796.                            MathTrans-Library (SPPow) noch nicht auf}
  797.  
  798.    Color;
  799.    LadKoord;
  800.    LadGet;
  801.    LadMark;
  802.  
  803.    NoHide:=TRUE;
  804.    ShowTitle(s, NoHide);
  805.  
  806.    IF Fast=1 THEN
  807.       FastDraw(0,0,640 DIV Modeflag,(Skonst*2) DIV Modeflag,xs,ys,FALSE)
  808.    ELSE
  809.       Areatest;
  810.  
  811.    IF (NOT Quit) AND
  812.     (Fast = 1) THEN BEGIN
  813.       Reqflag:=AutoRequest(bw,Feintxt,OK,Cancel,20,20,265,60);
  814.       IF ReqFlag THEN BEGIN
  815.          NoHide:=TRUE;
  816.          ShowTitle(s, NoHide);
  817.          Clear;
  818.          LadMark;
  819.          AreaTest;
  820.          Fast := 2;
  821.       END;
  822.    END;
  823.  
  824.    IF (NOT Quit) AND
  825.     (Fast = 2) THEN BEGIN
  826.       NoHide:=FALSE;
  827.       ShowTitle(s, NoHide);
  828.       REPEAT
  829.          Reqflag:=AutoRequest(bw,Repair,OK,Cancel,20,20,225,60);
  830.          IF ReqFlag THEN BEGIN
  831.             SetRepArea;
  832.             RepairArea;
  833.          END ELSE BEGIN
  834.             NoHide:=TRUE;
  835.             ShowTitle(s, NoHide);
  836.          END;
  837.       UNTIL ReqFlag = FALSE;
  838.    END;
  839.  
  840.    WHILE Quit=FALSE DO BEGIN
  841.       m:=WaitPort(bw^.UserPort);
  842.       m:=GetMsg(bw^.UserPort);
  843.       IF m <> nil THEN BEGIN
  844.          HandleMessage;
  845.       END;
  846.    END;
  847.  
  848.    CloseAll;
  849. END. {MAIN}
  850.  
  851. {-------------------------------------------------------------------------}
  852.