home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 15 / CDACTUAL15.iso / cdactual / program / pascal / HENON.ZIP / HENON2.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-12-22  |  29.5 KB  |  817 lines

  1.  
  2. PROGRAM HENON2;
  3. {$I GRAPH.P}
  4. CONST
  5.    MAX= 1E10;   {used in main loop to X and Y values in range}
  6.    MAXORBIT= 48; {maximum size of arrays used to store orbits}
  7.    BUFSIZE= 128;  {used below to define graphics screen buffer}
  8.    RECSIZE= 128;
  9. TYPE
  10.   HENONPLOT = RECORD  {these are the parameters of a plot}
  11.                 RA     :REAL;    {phase angle A}
  12.                 RAXIS  :INTEGER;  {chioce of axis for increments}
  13.                 RXOLD0 :REAL;    {initial starting point XOLD0,YOLD0}
  14.                 RYOLD0 :REAL;
  15.                 RDXY   :REAL;    {increment for starting points}
  16.                 RORBITN:INTEGER; {# of orbits in plot}
  17.                 RPOINTS:INTEGER; {# of points per orbit}
  18.                 RL     :REAL;    {window values,LEFT,RIGHT,BOTTOM,TOP}
  19.                 RR     :REAL;
  20.                 RB     :REAL;
  21.                 RT     :REAL;
  22.                 RX: ARRAY[1..MAXORBIT] OF REAL;   {orbits of plot-only}
  23.                 RY: ARRAY[1..MAXORBIT] OF REAL;   {essential if AXIS=4}
  24.                END;
  25. VAR
  26.   I,J,K,P1,P2,TP2,TQ2,TP1,TQ1,Q1,Q2,ORBITN,DECN,TEMP,ORBITN2: INTEGER;
  27.   ORBITL,RESPONSE,RESPON,AXIS,OPTION,POINTS:INTEGER;
  28.   R,L,T,B,A,XOLD,YOLD,XNEW,YNEW,XOLD0,YOLD0,DXY,BETA: REAL;
  29.   XSCALE,YSCALE,HALFW,COSA,SINA,COSB,SINB :REAL;
  30.   GRD,MARK,MNU,MEN,TXT,CHANGE,FIRSTTIME: BOOLEAN;
  31.   BLANKLINE: STRING[80]; CH: CHAR;
  32.   X,Y,XL,YL : ARRAY [1..MAXORBIT] OF REAL;   {for storing orbits}
  33.   CURRENT,PREVIOUS,STORED: HENONPLOT;        {for storing plot parameters}
  34.   BUFFER: ARRAY[1..RECSIZE,1..BUFSIZE] OF BYTE;  {temporay storage of screens}
  35.                                                                     
  36. PROCEDURE INTRO;
  37. BEGIN
  38.    CLRSCR;  {clear screen}
  39.    WRITELN('                  HENON MAPPING PROGRAM');
  40.    WRITELN('                  BY GORDON HUGHES, MATH DEPT');
  41.    WRITELN('                  CALIFORNIA STATE UNIVERSITY');
  42.    WRITELN('                  CHICO, CA , 95926');
  43.    WRITELN;
  44.    WRITELN('This program will create a Henon mapping to your specifications.');
  45.    WRITELN('A Henon mapping is an iterative mapping of the plane defined by:');
  46.    WRITELN;
  47.    WRITELN('      Xnew = Xold*Cos(A) - (Yold - Xold*Xold)*Sin(A) ');
  48.    WRITELN('      Ynew = Xold*Sin(A) + (Yold - Xold*Xold)*Cos(A) ');
  49.    WRITELN('  (where A is a given parameter, called the phase angle)');
  50.    WRITELN('After you finish a plot you can save your plot parameters or the actual plot.');
  51.    WRITELN('The program also allows you to modify existing plots.');
  52.    WRITELN;
  53.    WRITELN('You will be asked to input the following general types of information:');
  54.    WRITELN('(1): The phase angle A');
  55.    WRITELN('(2): The starting point (Xold,Yold) for each orbit of the plot.');
  56.    WRITELN('     These can be computed automatically by the program from an initial point');
  57.    WRITELN('     and an increment.');
  58.    WRITELN('(3): The number of points to be plotted for each orbit.');
  59.    WRITELN('(4): The window on the plot');
  60.    WRITELN;
  61.    WRITELN('Please hit any key to continue');
  62.    REPEAT UNTIL KEYPRESSED;
  63. END; {procedure intro}                                                  
  64.  
  65. PROCEDURE DISPLAYOPTIONS;
  66.  
  67. BEGIN
  68.    CLRSCR;
  69.    WRITELN;
  70.    WRITELN('THIS IS A LIST OF THE CURRENT SETTINGS. TO CHANGE ANY OF THESE');
  71.    WRITELN('ENTER THE NUMBER OF THE OPTION FOLLOWED BY A CARRIGE RETURN');
  72.    WRITELN;
  73.    IF GRD THEN WRITELN('(1) CO-ORDINATE GRID IS ON')
  74.    ELSE WRITELN('(1) CO-ORDINATE GRID IS OFF');
  75.    WRITELN;
  76.    IF TXT THEN WRITELN('(2) DISPLAY OF PLOT TEXT IS ON')
  77.    ELSE WRITELN('(2) DISPLAY OF PLOT TEXT IS OFF');
  78.    WRITELN;
  79.    IF MEN THEN WRITELN('(3) MENU DISPLAY IS ON')
  80.    ELSE WRITELN('(3) MENU DISPLAY IS OFF');
  81.    WRITELN;
  82.    IF MARK THEN WRITELN('(4) CROSS MARK AT STARTING POINT IS ON')
  83.    ELSE WRITELN('(4) CROSS MARK AT STARTING POINT IS OFF');
  84.    WRITELN;
  85.    WRITELN('(5) NUMBER OF DECIMAL PLACES FOR DISPLAY IS   ',DECN);
  86.    GOTOXY(1,23);
  87.    WRITELN('CARRIGE RETURN TO QUIT');
  88.    GOTOXY(1,15);
  89. END;  {procedure displayoptions}                                     
  90.  
  91. PROCEDURE CHANGEOPTIONS;
  92.  
  93. BEGIN
  94.  
  95.    REPEAT
  96.     OPTION:= 0;
  97.     READLN(OPTION);
  98.     CASE OPTION OF
  99.        1:  IF GRD THEN GRD:=FALSE ELSE GRD:= TRUE;
  100.        2:  IF TXT THEN TXT:= FALSE ELSE TXT:= TRUE;
  101.        3:  IF MEN THEN MEN:= FALSE ELSE MEN:= TRUE;
  102.        4:  IF MARK THEN MARK:=FALSE ELSE MARK:= TRUE;
  103.        5:  BEGIN
  104.               WRITELN;
  105.               WRITELN('HOW MANY PLACES WOULD YOU LIKE (2-11 WITHOUT 8087,2-16 WITH)');
  106.               READLN(DECN);
  107.            END;
  108.      END;
  109.     UNTIL OPTION = 0;
  110.  
  111. END; {procedure changeoptions}                                        
  112.  
  113. PROCEDURE SEARCH;     {interactive search using cursor keys}
  114. BEGIN
  115. HIRES;HIRESCOLOR(3);
  116. PUTPIC(BUFFER,0,199);   {restore last plot}
  117. P1:= ROUND((X[1]-L)*XSCALE); Q1:= ROUND((T- Y[1])*YSCALE);
  118. FOR K:= -6 TO 6 DO    {draw initial cross}
  119. BEGIN
  120.   PLOT(P1+K,Q1,1);
  121.   PLOT(P1,Q1+K,1);
  122. END;
  123.  
  124. GOTOXY(1,20);
  125. WRITELN('USE ARROW KEYS TO POSITION CROSS AT LOWER LEFT OF SEARCH AREA AND PRESS ESC');
  126. FIRSTTIME:= TRUE;  {used for erase routine}
  127. REPEAT
  128.    READ(KBD,CH);
  129.    IF (CH = #27) AND KEYPRESSED THEN
  130.    BEGIN
  131.       IF FIRSTTIME THEN
  132.     FOR K:= -6 TO 6 DO    {erase initial cross}
  133. BEGIN
  134.   PLOT(P1+K,Q1,0);
  135.   PLOT(P1,Q1+K,0);
  136. END;
  137.        READ(KBD,CH);
  138.        CASE CH OF
  139.            #75: X[1]:= X[1]-0.1*DXY; {left}
  140.            #77: X[1]:= X[1]+ 0.1*DXY; {RIGHT}
  141.            #72: Y[1]:= Y[1]+ 0.1*DXY; {up}
  142.            #80: Y[1]:= Y[1]-0.1*DXY; {down}
  143.         END; {CASE}
  144.  
  145.      P1:= ROUND((X[1]-L)*XSCALE); Q1:= ROUND((T- Y[1])*YSCALE);
  146.      IF NOT FIRSTTIME THEN  {erase old cross}
  147.      FOR K:= -4 TO 4 DO
  148.       BEGIN
  149.           PLOT(TP1+K,TQ1,0);
  150.           PLOT(TP1,TQ1+K,0);
  151.       END;
  152.  
  153.       FOR K:= -4 TO 4 DO
  154.       BEGIN
  155.                 PLOT(P1+K,Q1,1);
  156.                 PLOT(P1,Q1+K,1);
  157.       END;
  158.       TP1:= P1;TQ1:= Q1;  {save old values for erasure}
  159.      FIRSTTIME:= FALSE;
  160.      END;
  161.  UNTIL (CH =#27) AND NOT KEYPRESSED;                                     
  162.  
  163.  P1:= ROUND((X[1]-L)*XSCALE); Q1:= ROUND((T- Y[1])*YSCALE);
  164. GOTOXY(1,20);
  165. WRITELN('USE ARROW KEYS TO MOVE TO UPPER RIGHT CORNER OF SEARCH AREA AND PRESS ESC     ');
  166. FIRSTTIME:= TRUE;
  167. X[2]:= X[1];Y[2]:= Y[1];
  168. REPEAT
  169.    READ(KBD,CH);
  170.    IF (CH =#27) AND KEYPRESSED THEN
  171.    BEGIN
  172.        READ(KBD,CH);
  173.        CASE CH OF
  174.            #75: X[2]:= X[2]-0.1*DXY; {left}
  175.            #77: X[2]:= X[2]+ 0.1*DXY; {RIGHT}
  176.            #72: Y[2]:= Y[2]+ 0.1*DXY; {up}
  177.            #80: Y[2]:= Y[2]-0.1*DXY; {down}
  178.         END;
  179.      P2:= ROUND((X[2]-L)*XSCALE); Q2:= ROUND((T- Y[2])*YSCALE);
  180.      IF NOT FIRSTTIME THEN
  181.      BEGIN
  182.      DRAW(P1,Q1,P1,TQ2,0);   {erase old box}
  183.      DRAW(P1,TQ2,TP2,TQ2,0);
  184.      DRAW(TP2,TQ2,TP2,Q1,0);
  185.      DRAW(TP2,Q1,P1,Q1,0);
  186.      END;
  187.  
  188.      DRAW(P1,Q1,P1,Q2,1);   {draw new box}
  189.      DRAW(P1,Q2,P2,Q2,1);
  190.      DRAW(P2,Q2,P2,Q1,1);
  191.      DRAW(P2,Q1,P1,Q1,1);
  192.  
  193.  
  194.      TP2:= P2; TQ2:= Q2;   {save old values for erasure of old box}
  195.      FIRSTTIME:= FALSE;
  196.     END;
  197.  UNTIL (CH =#27) AND NOT KEYPRESSED;
  198.  
  199. END;   {procedure search}
  200.                                                                  
  201.  
  202. PROCEDURE DISPLAYORBITS;
  203.  
  204. BEGIN
  205.    WINDOW(1,3,80,25);
  206.    GOTOXY(1,2);
  207.    FOR K:= ORBITN + 1 TO MAXORBIT DO BEGIN X[K]:= 0.0; Y[K]:= 0.0 END; {zero junk}
  208.    IF ORBITN > 24 THEN WRITELN('THE FIRST 24 CURRENT ORBITS ARE')
  209.    ELSE WRITELN('THE CURRENT ORBITS ARE');
  210.    FOR K:= 1 TO 9 DO WRITELN('  ',K,'  ', X[K]:DECN:DECN-1,' ',Y[K]:DECN:DECN-1);
  211.    FOR K:= 10 TO 12 DO WRITELN(' ',K,'  ', X[K]:DECN:DECN-1,' ',Y[K]:DECN:DECN-1);
  212.    IF ORBITN >12 THEN
  213.    BEGIN
  214.       WRITELN;
  215.       WINDOW(2*DECN+8, 4,80,20); {continue on next column}
  216.       GOTOXY(1,1);
  217.       WRITELN;
  218.       FOR K:= 13 TO 24 DO WRITELN('   ', K,'  ', X[K]:DECN:DECN-1,' ',Y[K]:DECN:DECN-1);
  219.     END;
  220.     WINDOW(1,1,80,25);GOTOXY(1,18);
  221. END; {procedure displayorbits}
  222.                                                                    
  223. PROCEDURE DISPLAYDATA;
  224.  
  225. BEGIN
  226.    CLRSCR;
  227.    WRITELN('                           THE CURRENT PLOT DATA IS:');
  228.    WRITELN('PHASE ANGLE A = ', A:5:4);
  229.    IF AXIS <>4 THEN
  230.    BEGIN
  231.       WRITELN;
  232.       WRITE('AXIS SELECTED IS: ');
  233.       CASE AXIS OF
  234.          1: WRITELN('(1) AXIS OF SYMMETRY');
  235.          2: WRITELN('(2)  X AXIS');
  236.          3: WRITELN('(3)  AXIS OF CHOICE');
  237.       END;
  238.       WRITELN;
  239.       WRITELN('STARTING POINT X0,Y0 IS ',X[1]:DECN:DECN-1, '  ',Y[1]:DECN:DECN-1);
  240.       WRITELN;
  241.       WRITELN('INCREMENT DXY = ', DXY:DECN:DECN-1);
  242.       WRITELN;
  243.       WRITELN('NUMBER OF ORBITS = ',ORBITN);
  244.       WRITELN;
  245.       WRITELN('NUMBER OF POINTS PER ORBIT = ',POINTS);
  246.       WRITELN;
  247.       WRITELN('WINDOW VALUES ARE:');
  248.       WRITELN('   X-AXIS: ',L:DECN:DECN-1, ' TO ',R:DECN:DECN-1,'  YAXIS: ',B:DECN:DECN-1, ' TO',T:DECN:DECN-1);
  249.       WRITELN;
  250.     END
  251.     ELSE
  252.     BEGIN
  253.       DISPLAYORBITS;
  254.       WRITELN('TOTAL NUMBER OF ACTIVE ORBITS= ',ORBITN);
  255.       WRITELN('NUMBER OF POINTS PER ORBIT = ',POINTS);
  256.       WRITELN('WINDOW VALUES ARE:');
  257.       WRITELN('  X-AXIS:  ',L:DECN-2:DECN-3, ' TO ',R:DECN-2:DECN-3,'  YAXIS: ',B:DECN-2:DECN-3, ' TO',T:DECN-2:DECN-3);
  258.     END;
  259.     IF XOLD0 = 0.0 THEN BETA:= PI/2    {update BETA}
  260.     ELSE  BETA:= ARCTAN(YOLD0/XOLD0);
  261.     XSCALE:= 640/(R-L); YSCALE:= 200/(T-B);   {update scale factors}
  262.     GOTOXY(1,23);
  263.     WRITELN('IF THERE ARE NO CHANGES PRESS ESCAPE TO START PLOT');
  264.     WRITE('OTHERWISE PRESS ANY OTHER KEY TO CONTINUE');
  265.     REPEAT UNTIL KEYPRESSED;
  266.     BEGIN
  267.        READ(KBD,CH);
  268.        IF (CH = #27) AND NOT KEYPRESSED THEN CHANGE:= FALSE ELSE CHANGE:= TRUE;
  269.      END;
  270.     WINDOW(1,1,80,25); GOTOXY(1,1);
  271.  END; {procedure displaydata}
  272.  
  273.  
  274.                                                                            
  275. PROCEDURE MODIFYORBITS;
  276.  
  277. VAR
  278.   ORBIT1,ORBIT2:INTEGER;
  279.  
  280. BEGIN
  281.    CLRSCR;DISPLAYORBITS;
  282.    WRITELN('PLEASE SELECT ONE:');
  283.    WRITELN('          (1) KEEP SAME ORBITS BUT CHANGE NUMBER OF POINTS PER ORBIT');
  284.    WRITELN('          (2) EXPAND ON A SUBSET OF THESE ORBITS');
  285.    WRITELN('          (3) EXPAND ABOUT A SINGLE ORBIT');
  286.    WRITELN('          (4) EXPAND INTERACTIVELY ABOUT A POINT FROM LAST PLOT');
  287.    WRITELN('          (5) ENTER NEW ORBITS');
  288.    WRITELN('          CARRIGE RETURN TO START PLOT');
  289.    READLN(RESPON);
  290.    CASE RESPON OF
  291.    1:BEGIN
  292.  
  293.       WRITELN;
  294.       WRITELN('INPUT THE NUMBER OF POINTS TO BE PLOTTED PER ORBIT. MAX IS 32000');
  295.       READLN(POINTS);
  296.      END;
  297.    2:
  298.      BEGIN
  299.      AXIS:= 4;
  300.       ORBIT1:=1;ORBIT2:=ORBITN;  {defaults}
  301.       WRITELN('INPUT THE STARTING ORBIT # AND FINAL ORBIT # FOR NEW PLOT');
  302.       READLN(ORBIT1,ORBIT2);
  303.       WRITELN('INPUT NUMBER OF ORBITS IN THE NEW PLOT');
  304.       READLN(ORBITN);
  305.       X[1]:= X[ORBIT1]; Y[1]:= Y[ORBIT1];X[ORBITN]:= X[ORBIT2];Y[ORBITN]:= Y[ORBIT2];
  306.       DXY:= SQRT( SQR (X[ORBIT2] -X[ORBIT1]) + SQR(Y[ORBIT2]-Y[ORBIT1]))/(ORBITN-1);
  307.       WRITELN('INPUT THE NUMBER OF POINTS FOR EACH ORBIT');
  308.       READLN(POINTS);
  309.       BETA:= ARCTAN(Y[1]/X[1]);
  310.  
  311.       FOR K:= 2 TO ORBITN-1 DO     {generate new orbits}
  312.       BEGIN
  313.          X[K]:= X[K-1]+ DXY*COS(BETA);
  314.          Y[K]:= Y[K-1]+ DXY*SIN(BETA);
  315.       END;
  316.       XOLD0:= X[1];YOLD0:= Y[1];
  317.      END;
  318.                                                                   
  319.   3: BEGIN
  320.  AXIS:= 4;
  321.         WRITELN('PLEASE ENTER THE CO-ORDINATES OF THE POINT OF INTEREST');
  322.         READLN(XNEW,YNEW);
  323.         WRITELN('PLEASE ENTER THE INCREMENT DXY'); READLN(DXY);
  324.  
  325.         WRITELN('PLEASE ENTER THE NUMBER OF ORBITS DESIRED ON EACH SIDE OF THE POINT');
  326.         WRITELN('OF INTEREST: ORBITS TOWARD THE ORIGIN AND ORBITS AWAY FROM IT');
  327.         READLN(ORBIT1,ORBIT2);
  328.         ORBITN:= ORBIT1 + ORBIT2 + 1;
  329.  IF XNEW <> 0.0 THEN
  330.         BETA:= ARCTAN(YNEW/XNEW)
  331.  ELSE BETA:= 0.0;
  332.         X[1]:= XNEW - ORBIT1*DXY*COS(BETA);
  333.         Y[1]:= YNEW - ORBIT1*DXY*SIN(BETA);
  334.         FOR K:= 2 TO ORBITN DO
  335.         BEGIN
  336.            X[K]:= X[K-1]+ DXY*COS(BETA);
  337.            Y[K]:= Y[K-1]+ DXY*SIN(BETA);
  338.         END;
  339.         X[ORBIT1+1]:= XNEW;Y[ORBIT1+1]:= YNEW;  {to make sure this point is included}
  340.         WRITELN('PLEASE INPUT THE NUMBER OF POINTS PER ORBIT');
  341.         READLN(POINTS);
  342.       END;
  343.  
  344.      4: BEGIN
  345.    AXIS:= 4;
  346.           SEARCH;  {now X[1],Y[1], X[2],Y[2] contain lower left and upper right of search area}
  347.           WRITELN('INPUT THE NUMBER OF ORBITS DESIRED');
  348.           READLN(ORBITN);
  349.           IF ORBITN <> 1 THEN DXY:= SQRT( SQR (X[2]-X[1]) + SQR(Y[2]-Y[1]))/(ORBITN-1)
  350.    ELSE DXY:= 0.0;  {only one orbit desired}
  351.           WRITELN('INPUT THE NUMBER OF POINTS FOR EACH ORBIT');
  352.           READLN(POINTS);
  353.           IF X[2] <> X[1] THEN BETA:= ARCTAN(Y[2]-Y[1])/(X[2]-X[1])
  354.    ELSE BETA:= PI/2;
  355.           FOR K:= 2 TO ORBITN DO     {generate new orbits}
  356.           BEGIN
  357.              X[K]:= X[K-1]+ DXY*COS(BETA);
  358.              Y[K]:= Y[K-1]+ DXY*SIN(BETA);
  359.           END;
  360.           XOLD0:= X[1];YOLD0:= Y[1];
  361.           END;
  362.  
  363.    5:BEGIN
  364.       AXIS:= 4;
  365.       WRITELN('EXISTING ORBITS WILL REMAIN UNLESS CHANGED. HOW MANY ORBITS');
  366.       WRITELN('WOULD YOU LIKE TO REMAIN ?');
  367.       READLN(ORBITN);
  368.          WRITELN('PLEASE ENTER ANY NEW ORBITS IN THE FORM: ORBIT#  X   Y');
  369.          WRITELN('WHEN FINISHED ENTER 0 ORBIT# TO TERMINATE');
  370.          WHILE I > 0 DO READLN(I,X[I],Y[I]);
  371.   WRITELN('PLEASE ENTER THE NUMBER OF POINTS PER ORBIT');
  372.   READLN(POINTS);
  373.       END;  {item 3}
  374.   END; {case}
  375.   XOLD0:= X[1];YOLD0:= Y[1];
  376.   CLRSCR;
  377.   DISPLAYORBITS;
  378.   GOTOXY(1,22);WRITELN('PRESS ANY KEY TO CONTINUE');
  379.   REPEAT UNTIL KEYPRESSED;
  380.   RESPON:= 0;
  381. END; {procedure modifyorbits}                                    
  382.  
  383. PROCEDURE OBTAINDATA;
  384. BEGIN
  385.    CLRSCR;
  386.    IF (RESPONSE <> 2) THEN      {skip A and AXIS input for MENU item 2}
  387.    BEGIN
  388.    WRITELN('INPUT PHASE ANGLE A (IN RADIANS BETWEEN 0.0 AND PI)');
  389.    WRITE('CURRENT VALUE IS  ');WRITE(A:DECN:DECN-1, '      ');
  390.    READLN(A);WRITELN;
  391.    SINA:= SIN(A); COSA:= COS(A);
  392.  
  393.    WRITELN('INCREMENT ALONG: (1) AXIS OF SYMMETRY   (2) X-AXIS');
  394.    WRITELN('                 (3) AXIS OF CHOICE     (4) NO AXIS-ORBITS FROM ARRAYS X AND Y');
  395.    WRITE('CURRENT VALUE IS '); WRITE(AXIS, '      ');
  396.    READLN(AXIS);WRITELN;
  397.    END;
  398.  
  399.    CASE AXIS OF
  400.       1: BEGIN
  401.             BETA:= A/2;
  402.             IF BETA < PI/4 THEN
  403.             BEGIN
  404.                WRITELN('INPUT STARTING POINT X0');
  405.                WRITE('CURRENT VALUE IS ');WRITE(XOLD0:DECN:DECN-1, '      ');
  406.                READLN(XOLD0); WRITELN;
  407.                YOLD0:= SIN(BETA)*XOLD0/COS(BETA);
  408.             END ELSE
  409.             BEGIN
  410.                WRITELN('INPUT STARTING POINT Y0');
  411.                WRITE('CURRENT VALUE IS ');WRITE(YOLD0:DECN:DECN-1,'      ');
  412.                READLN(YOLD0); WRITELN;
  413.                XOLD0:= COS(BETA)*YOLD0/SIN(BETA)
  414.             END; {if A}
  415.          END; {item 1}
  416.       2: BEGIN
  417.             BETA:= 0.0;
  418.             WRITELN('INPUT STARTING POINT X0');
  419.             WRITE('CURRENT VALUE IS  ');WRITE(XOLD0:DECN:DECN-1, '    ');
  420.             READLN(XOLD0); WRITELN;
  421.             YOLD0:= 0.0;
  422.          END;
  423.       3: BEGIN
  424.             WRITELN('INPUT X AND Y CO-ORDINATES OF ANY POINT ON THE DESIRED AXIS');
  425.             WRITE('CURRENT VALUE IS  ');WRITE(XOLD0:DECN:DECN-1,'  ',YOLD0:DECN:DECN-1,'    ');
  426.             READLN(XOLD0,YOLD0); WRITELN;
  427.             IF XOLD0 = 0.0 THEN
  428.             BEGIN
  429.                BETA:= PI/2;
  430.                WRITELN('INPUT STARTING POINT Y0') ;
  431.                WRITE('CURRENT VALUE IS  ');WRITE(YOLD0:DECN:DECN-1,'       ');
  432.                READLN(YOLD0);WRITELN;
  433.             END
  434.             ELSE
  435.             BEGIN
  436.                BETA:= ARCTAN(YOLD0/XOLD0);
  437.                WRITELN('INPUT STARTING POINT X0');
  438.                WRITE('CURRENT VALUE IS  '); WRITE(XOLD0:DECN:DECN-1,'       ');
  439.                READLN(XOLD0); WRITELN; YOLD0:= XOLD0*SIN(BETA)/COS(BETA);
  440.             END;
  441.          END;
  442.        4: MODIFYORBITS;
  443.    END;   {case}                                                  
  444.  
  445.    IF AXIS <> 4 THEN
  446.    BEGIN
  447.       WRITELN('INPUT INCREMENT DXY');
  448.       WRITE('CURRENT VALUE IS '); WRITE(DXY:DECN:DECN-1, '     ');
  449.       READLN(DXY);WRITELN;
  450.       WRITELN('INPUT NUMBER OF ORBITS');
  451.       WRITE('CURRENT VALUE IS ');WRITE(ORBITN, '        ');
  452.       READLN(ORBITN); WRITELN;
  453.       WRITELN('INPUT NUMBER OF POINTS FOR EACH ORBIT');
  454.       WRITE('CURRENT VALUE IS '); WRITE(POINTS, '        ');
  455.       READLN(POINTS); WRITELN;
  456.       X[1]:= XOLD0; Y[1]:= YOLD0;
  457.       X[ORBITN]:= X[1]+ DXY*ORBITN*COS(BETA); {these might be needed for automatic calculation}
  458.       Y[ORBITN]:= Y[1]+ DXY*ORBITN*SIN(BETA); {of window below}
  459.     END;
  460.  
  461.    WRITELN('INPUT LEFT AND RIGHT WINDOW VALUES (ENTER 0.0,0.0 FOR AUTO CALCULATION) ');
  462.       WRITE('CURRENT VALUE IS  ');WRITE(L:DECN:DECN-1, '  ',R:DECN:DECN-1, '      ');
  463.       READLN(L,R);
  464.       IF L = R THEN { perform auto calculation of window}
  465.       BEGIN    {first find largest leg of final orbits}
  466.           IF ABS(X[ORBITN]-X[1]) > ABS(Y[ORBITN]-Y[1]) THEN HALFW:= X[ORBITN]-X[1] ELSE
  467. HALFW:=Y[ORBITN]-Y[1];
  468.           L:= X[1]- HALFW; R:= X[1]+ 1.1*HALFW;
  469.           B:= Y[1]- HALFW; T:= Y[1]+ 1.1*HALFW;
  470.       END
  471.       ELSE
  472.       BEGIN
  473.          WRITELN;
  474.          WRITELN('INPUT BOTTOM AND TOP WINDOW VALUES');
  475.          WRITE('CURRENT VALUE IS  ');WRITE(B:DECN:DECN-1, '  ',T:DECN:DECN-1, '     ');
  476.          READLN(B,T);
  477.       END;
  478. XSCALE:= 640/(R-L);YSCALE:= 200/(T-B);
  479. END; {procedure obtaindata}
  480.                                                                          
  481.  
  482.  
  483. PROCEDURE DRAWGRID;
  484.  
  485. VAR
  486.   ZX,ZY:INTEGER;  { zx,zy is the origin of the plot}
  487.  
  488. BEGIN
  489.    IF (ABS(L*XSCALE) < 30000) AND (ABS(T*YSCALE) < 30000) THEN
  490.    BEGIN
  491.    ZX:= ROUND((0.0-L)*XSCALE);   {compute origin (ZX,ZY)}
  492.    ZY:= ROUND((T - 0.0)*YSCALE)
  493.    END
  494.    ELSE
  495.    BEGIN
  496.     ZX:= 639;
  497.     ZY:= 199
  498.    END;
  499.    DRAW(0,ZY,640,ZY, 1);             {draw X and Y axes}
  500.    DRAW(ZX,0,ZX,200, 1);
  501.  
  502.    IF (L > 0.0)  AND (B > 0.0)  THEN    {if origin off screen}
  503.    BEGIN ZX:=639;ZY:=199 END;           {set it to edge to retain grid marks}
  504.    FOR J:=-10 TO 10 DO     {draw grid marks starting at origin}
  505.    BEGIN
  506.       DRAW(ZX+64*J,ZY+3,ZX+ 64*J,ZY-3,1);
  507.       DRAW(ZX+5,ZY+20*J,ZX-5,ZY+20*J,1);
  508.    END;
  509.  END;  {procedure drawgrid}
  510.  
  511. PROCEDURE  DRAWTEXT;
  512. BEGIN
  513.    IF AXIS = 4 THEN
  514.    BEGIN XOLD0:= X[1]; YOLD0:= Y[1] END;
  515.    GOTOXY(1,1);                {display plot parameters}
  516.    WRITELN('A = ',A:5:4);
  517.    WRITELN;
  518.    WRITELN('INITIAL ORBIT:');
  519.    WRITELN('X0,Y0 = ',XOLD0:DECN:DECN-1,',',YOLD0:DECN:DECN-1);
  520.    WRITELN;
  521.    IF AXIS <> 4 THEN
  522.    BEGIN
  523.       WRITELN('INCREMENT ALONG:');
  524.       CASE AXIS OF
  525.          1: WRITELN('AXIS OF SYMMETRY');
  526.          2: WRITELN('X AXIS');
  527.          3: WRITELN('AXIS OF CHOICE');
  528.       END;
  529.     END
  530.     ELSE
  531.     WRITELN('ORBITS FROM ARRAYS');
  532.     WRITELN;
  533.     IF (RESPON <> 2) AND (RESPONSE <> 8) THEN WRITELN('INCREMENT DXY = ',DXY:DECN:DECN-1);
  534.     GOTOXY(1,14);
  535.     IF GRD THEN
  536.     BEGIN
  537.        WRITELN('X SCALE: ',L:DECN:DECN-1,' TO ',R:DECN:DECN-1);
  538.        WRITELN('Y SCALE: ',B:DECN:DECN-1,' TO ',T:DECN:DECN-1);
  539.        WRITELN('XGRID MARK: ',(R-L)/(640/64):DECN:DECN-1);
  540.        WRITELN('YGRID MARK: ', (T-B)/(200/20):DECN:DECN-1);
  541.     END;
  542.     GOTOXY(1,20);
  543.     WRITELN('PRESS ANY KEY TO ADVANCE ORBITS MANUALLY');
  544. END; {procedure drawtext}
  545.                                                                           
  546. PROCEDURE PLOTORBITS;
  547.  
  548. CONST  MAXREAL: REAL = 1E+30;
  549.  
  550. VAR
  551.   P1,P2:INTEGER;
  552.  
  553. BEGIN
  554. SINB:= SIN(BETA); COSB:= COS(BETA);
  555. SINA:=SIN(A);COSA:= COS(A);
  556. FOR J:= 1 TO ORBITN  DO   {generate starting points Xold0,yold0 for each orbit}
  557. BEGIN
  558.    GOTOXY(1,11);
  559.    IF TXT THEN
  560.    WRITELN('ORBIT #',J, ' OF ',ORBITN,':');
  561.    IF AXIS = 4 THEN
  562.    BEGIN XOLD0:= X[J]; YOLD0:= Y[J] END;  {use arrays in no-axis option}
  563.    IF J <= MAXORBIT THEN
  564.    BEGIN X[J]:= XOLD0; Y[J]:= YOLD0 END;  {update matrix}
  565.    IF TXT THEN
  566.    WRITELN('X0,Y0 = ', XOLD0:DECN:DECN-1, '  ',YOLD0:DECN:DECN-1);
  567.    XOLD:= XOLD0; YOLD:= YOLD0;   {set starting point to xold0,yold0}
  568.    IF MARK THEN {draw a mark at the initial point XOLD0,YOLD0}
  569.    BEGIN
  570.       P1:= ROUND((XOLD-L)*XSCALE); P2:= ROUND((T- YOLD)*YSCALE);
  571.       FOR K:= -2 TO 2  DO
  572.       BEGIN
  573.          PLOT(P1+K,P2,1);
  574.          PLOT(P1,P2+K,1)
  575.       END;
  576.       IF RESPONSE= 8 THEN  {for merged plots use two values of POINTS}
  577.       IF J > PREVIOUS.RORBITN THEN POINTS:=STORED.RPOINTS;
  578.  
  579.   END;
  580.   I:= 1;
  581.   WHILE I <= POINTS DO
  582.   BEGIN
  583.  
  584.       IF (ABS(XOLD) < MAX) AND (ABS(YOLD) < MAX) THEN  {check for out of range}
  585.       BEGIN
  586.          XNEW:=  XOLD*COSA -(YOLD-XOLD*XOLD)*SINA;  {The Henon mapping}
  587.          YNEW:=  XOLD*SINA + (YOLD-XOLD*XOLD)*COSA;
  588.          IF (ABS(XNEW-L) < MAXINT/XSCALE) AND (ABS(T-YNEW) < MAXINT/YSCALE) THEN
  589.          BEGIN
  590.             P1:= ROUND((XNEW-L)*XSCALE);  {scale the new point for plotting}
  591.             P2:= ROUND((T-YNEW)*YSCALE);
  592.             PLOT(P1,P2,1);
  593.          END;
  594.          XOLD:= XNEW;
  595.          YOLD:= YNEW;
  596.   END;
  597.          IF KEYPRESSED THEN I:= POINTS+1 ELSE I:= I+ 1;
  598.   END;  {WHILE I. End of orbit plot}
  599.  
  600.    XOLD0:= XOLD0 + COSB*DXY; {increment along chosen axis}
  601.    YOLD0:= YOLD0 + SINB*DXY;
  602.  
  603. END;  {For J. Start next orbit}
  604. END;  {procedure plotorbits}
  605.                                                                            
  606.  
  607. PROCEDURE MENU;
  608.  
  609. VAR
  610.    FIL: FILE;  {untyped file for storing screen images}
  611.    FIL2: TEXT; {text file for storing parameters}
  612.    PICNAME,FNAME: STRING[14];
  613.    MNU: BOOLEAN;
  614.  
  615. BEGIN
  616.    MNU:= TRUE;
  617.    GETPIC(BUFFER,0,0,639,199); {store screen in buffer}
  618.    WITH CURRENT DO    {save plot parameters in record CURRENT}
  619.    BEGIN
  620.       RA:= A;RAXIS:= AXIS;RXOLD0:= X[1];RYOLD0:= Y[1];
  621.       RDXY:= DXY;RORBITN:= ORBITN;RPOINTS:= POINTS;RL:=L;
  622.       RR:= R;RB:= B; RT:= T;
  623.       FOR K:= 1 TO MAXORBIT DO
  624.       BEGIN
  625.          RX[K]:= X[K]; RY[K]:= Y[K];
  626.       END;
  627.     END;
  628.  
  629.  WHILE MNU DO
  630.  BEGIN
  631.    RESPONSE:= 0;
  632.    GOTOXY(1,19);
  633.    FOR I:= 1 TO 6 DO WRITELN(BLANKLINE);
  634.    GOTOXY(1,19);
  635.    WRITELN('SELECT ONE: (F1) NEW PLOT (CARRIGE RETURNS WILL REPEAT CURRENT VALUES)');
  636.    WRITELN('(F2) REVISE ORBITS OF CURRENT PLOT        (F3) RESTORE PREVIOUS PLOT');
  637.    WRITELN('(F4) SAVE PARAMETERS OF CURRENT PLOT      (F5) SAVE SCREEN OF CURRENT PLOT');
  638.    WRITELN('(F6) RETRIEVE STORED PARAMETERS           (F7) RETRIEVE STORED SCREEN  ');
  639.    WRITELN('(F8) MERGE CURRENT PLOT WITH STORED PLOT  (F9) CHANGE OPTIONS  (F10) QUIT');
  640.    REPEAT UNTIL KEYPRESSED;     {detect whether any of the 10 function keys are pressed}
  641.    READ(KBD,CH);
  642.    IF (CH = #27) AND KEYPRESSED THEN  READ(KBD,CH);  {function keys generate two characters}
  643.  
  644.    CASE CH OF
  645.         #59: BEGIN     {F1 pressed- New Plot}
  646.       RESPONSE:= 1;
  647.              MNU:= FALSE; {do not repeat menu}
  648.              PREVIOUS:= CURRENT;   {save current parameters}
  649.              XOLD0:=X[1];YOLD0:= Y[1];
  650.           END;
  651.         #60: BEGIN
  652.       RESPONSE:= 2;    {F2 pressed-Modify orbits}
  653.              MNU:= FALSE; {do not repeat menu}
  654.              PREVIOUS:= CURRENT;
  655.              AXIS:= 4;
  656.           END;                                                              
  657.  
  658.         #61: BEGIN     {F3 pressed-restore previous plot}
  659.  
  660.        RESPONSE:= 3;
  661.               MNU:= FALSE;
  662.               WITH PREVIOUS DO
  663.               BEGIN
  664.                  A:= RA;AXIS:= RAXIS;XOLD0:=RXOLD0;YOLD0:= RYOLD0;
  665.                  DXY:= RDXY; ORBITN:= RORBITN;POINTS:= RPOINTS;
  666.                  L:= RL;R:=RR;B:=RB;T:=RT;
  667.                  FOR K:= 1 TO MAXORBIT DO
  668.                  BEGIN
  669.                     X[K]:= RX[K]; Y[K]:= RY[K];
  670.                  END;
  671.               END;
  672.               PREVIOUS:= CURRENT;
  673.             END;
  674.         #62: BEGIN
  675.        RESPONSE:= 4;   {F4 pressed-save plot parameters in text file}
  676.               MNU:= TRUE;
  677.        TEMP:= DECN; {to restore current decimal places}
  678.               DECN:= 16;  {change this to 11 without 8087 support}
  679.               GOTOXY(1,23);WRITE(BLANKLINE);GOTOXY(1,23);
  680.               WRITE('INPUT NAME OF FILE TO CONTAIN PARAMETERS    ');READ(FNAME);
  681.               ASSIGN(FIL2, FNAME); REWRITE(FIL2);
  682.               WRITELN(FIL2,A:DECN:DECN-1);WRITELN(FIL2,AXIS);WRITELN(FIL2,X[1]:DECN:DECN-1);
  683.               WRITELN(FIL2,Y[1]:DECN:DECN-1);WRITELN(FIL2,DXY:DECN:DECN-1);WRITELN(FIL2,ORBITN);
  684.               WRITELN(FIL2,POINTS);WRITELN(FIL2,L:DECN:DECN-1);WRITELN(FIL2,R:DECN:DECN-1);
  685.               WRITELN(FIL2,B:DECN:DECN-1);WRITELN(FIL2,T:DECN:DECN-1);
  686.               FOR K:= 1 TO MAXORBIT DO  WRITELN(FIL2,X[K]:DECN:DECN-1,' ',Y[K]:DECN:DECN-1);
  687.                              {use formatted write for compatability without 8087}
  688.                              {note single space between X[K] & Y[K]-seems necessary}
  689.                              {for Pascal to read these properly}
  690.               CLOSE(FIL2);
  691.        DECN:= TEMP;
  692.            END;
  693.         #63: BEGIN
  694.        RESPONSE:= 5;   {F5 pressed-save graphics plot in untyped file}
  695.               MNU:= TRUE;
  696.               GOTOXY(1,23); WRITE(BLANKLINE);GOTOXY(1,23);
  697.               WRITE('INPUT NAME OF FILE TO CONTAIN PLOT    ');READ(PICNAME);
  698.               ASSIGN(FIL,PICNAME); REWRITE(FIL);
  699.               BLOCKWRITE(FIL,BUFFER,127);  CLOSE(FIL);
  700.               GOTOXY(1,18) ; WRITELN('COPY COMPLETE.PLEASE CHOOSE FROM MENU');
  701.            END;
  702.         #64: BEGIN
  703.        RESPONSE:= 6;    {F6 pressed-retrieve stored parameters}
  704.               MNU:= FALSE;
  705.               PREVIOUS:= CURRENT;  {save old parameters}
  706.               GOTOXY(1,23);WRITE(BLANKLINE);GOTOXY(1,23);
  707.               WRITE('INPUT NAME OF FILE WHERE PARAMETERS ARE STORED     ');
  708.               READLN(FNAME);
  709.               ASSIGN(FIL2,FNAME);RESET(FIL2);
  710.               READLN(FIL2,A); READLN(FIL2,AXIS); READLN(FIL2,XOLD0);
  711.               READLN(FIL2,YOLD0);READLN(FIL2,DXY);READLN(FIL2,ORBITN);
  712.               READLN(FIL2,POINTS);READLN(FIL2,L);READLN(FIL2,R);
  713.               READLN(FIL2,B);READLN(FIL2,T);
  714.               FOR K:= 1 TO MAXORBIT DO  READLN(FIL2,X[K],Y[K]);
  715.               CLOSE(FIL2);
  716.        IF ORBITN <= MAXORBIT THEN AXIS:= 4 ;  {use existing arrays}
  717.               WITH CURRENT DO    {store plot parameters in record CURRENT}
  718.               BEGIN
  719.                  RA:= A;RAXIS:= AXIS;RXOLD0:= X[1];RYOLD0:= Y[1];
  720.                  RDXY:= DXY;RORBITN:= ORBITN;RPOINTS:= POINTS;RL:=L;
  721.                  RR:= R;RB:= B; RT:= T;
  722.                  FOR K:= 1 TO ORBITN DO
  723.                  BEGIN
  724.                     RX[K]:= X[K];RY[K]:= Y[K];
  725.                  END;
  726.               END;
  727.            END;                                                   
  728.         #65: BEGIN     {F7 pressed-retrieve graphics screen}
  729.        RESPONSE:= 7;
  730.               GOTOXY(1,23); WRITE(BLANKLINE);GOTOXY(1,23);
  731.               WRITE('INPUT NAME OF FILE WHERE SCREEN IS STORED     ');
  732.               READLN(PICNAME);
  733.               ASSIGN(FIL,PICNAME);RESET(FIL);BLOCKREAD(FIL,BUFFER,127);
  734.        HIRES;HIRESCOLOR(3);
  735.               PUTPIC(BUFFER,0,199); CLOSE(FIL);
  736.               GOTOXY(1,23);
  737.               WRITELN('TO MODIFY THIS PLOT,ENTER THE PARAMETERS USING ITEM(1) OF THE MENU');
  738.               WRITE('PRESS ANY KEY TO CONTINUE');
  739.               REPEAT UNTIL KEYPRESSED;
  740.            END;
  741.  
  742.         #66: BEGIN
  743.         RESPONSE:= 8;   {F8 pressed-merge orbits of current plot with stored plot}
  744.                MNU:=FALSE;
  745.                PREVIOUS:= CURRENT;
  746.                GOTOXY(1,23);WRITE(BLANKLINE);GOTOXY(1,23);
  747.                WRITE('INPUT NAME OF FILE WHERE PARAMETERS ARE STORED   ');
  748.                READLN(FNAME);
  749.                ASSIGN(FIL2,FNAME);RESET(FIL2);
  750.                WITH STORED DO   {put parameters in record STORED}
  751.                BEGIN
  752.                   READLN(FIL2,RA); READLN(FIL2,RAXIS); READLN(FIL2,RXOLD0);
  753.                   READLN(FIL2,RYOLD0);READLN(FIL2,RDXY);READLN(FIL2,RORBITN);
  754.                   READLN(FIL2,RPOINTS);READLN(FIL2,RL);READLN(FIL2,RR);
  755.                   READLN(FIL2,RB);READLN(FIL2,RT);
  756.                   FOR K:= 1 TO MAXORBIT DO READLN(FIL2,RX[K],RY[K]);
  757.                   CLOSE(FIL2);
  758.  
  759.                   FOR K:= 1 TO  (MAXORBIT-ORBITN) DO  {merge arrays-including}
  760.                   BEGIN                             {any zero elements}
  761.                      X[ORBITN+K]:= RX[K];Y[ORBITN +K]:= RY[K];
  762.                   END;
  763.  
  764.                   IF ORBITN+RORBITN <MAXORBIT THEN
  765.                   ORBITN:=ORBITN+RORBITN ELSE ORBITN:= MAXORBIT;
  766.                 END;  {with stored}
  767.                 AXIS:= 4;
  768.  
  769.             END;
  770.         #67: BEGIN    {F9 pressed-change options such as TEXT,GRID,MARK}
  771.                RESPONSE:= 9;
  772.                DISPLAYOPTIONS;
  773.                CHANGEOPTIONS
  774.             END;
  775.         #68: BEGIN   {F10 pressed-quit}
  776.                 RESPONSE:= 10;
  777.                 MNU:=FALSE;
  778.              END;
  779.       END;  {Case}
  780.     END; {while}
  781.  END;  {procedure menu}
  782.  
  783.                                                                    
  784. BEGIN  {main program}
  785.  
  786.    GRD:= TRUE; MARK:= TRUE;TXT:= TRUE;MEN:= TRUE;    {defaults}
  787.    L:=-1.2;R:= 1.2; B:= -1.2; T:= 1.2;
  788.    ORBITN:=25; POINTS:= 500;DECN:= 5;
  789.    BLANKLINE:= '                                                                               ';
  790.    FOR K:= 1 TO 40 DO BEGIN X[K]:= 0.0; Y[K]:= 0.0;XL[K]:= 0.0;YL[K]:= 0.0 END;
  791.    A:= 1.111; RESPONSE:= 0;
  792.    AXIS:= 1;XOLD0:=0.098;YOLD0:=0.061; DXY:= 0.05;
  793.  
  794.    INTRO;
  795.    REPEAT
  796.  
  797.       DISPLAYDATA;
  798.       IF CHANGE THEN
  799.       OBTAINDATA;
  800.       HIRES;HIRESCOLOR(3);
  801.       IF GRD THEN
  802.       DRAWGRID;
  803.       IF TXT THEN
  804.       DRAWTEXT;
  805.       PLOTORBITS;
  806.       IF MEN THEN
  807.       MENU
  808.       ELSE
  809.       BEGIN
  810.         GOTOXY(1,24);WRITELN('PRESS ANY KEY FOR MENU');
  811.         REPEAT UNTIL KEYPRESSED;
  812.         MENU
  813.       END;
  814.  
  815.    UNTIL RESPONSE = 10;
  816. END.
  817.