~trn/reduce-algebra

d826e978f3383b9c30f79a9387383cf86a44c4ab — Jeffrey H. Johnson 13 days ago 678bd44 + a572587
Merge branch 'svn/trunk'
M packages/alg/simptrig.red => packages/alg/simptrig.red +17 -16
@@ 122,7 122,7 @@ Not yet implemented:


symbolic procedure simp!-trig!-arg u;
   begin scalar r,okord,!*mcd,!*exp,dmode!*;
   begin scalar r,okord,!*mcd,!*exp,!*factor,dmode!*;
     okord := setkorder '(pi);
     !*mcd := !*exp := t;
     r := simp u;


@@ 132,23 132,24 @@ symbolic procedure simp!-trig!-arg u;


symbolic procedure pi_split u;
   begin scalar du,nu,l;
 % looks for a term linear in pi
 % returns a pair of the coeff of the linear term and u
   begin scalar du,nu,ddeg,dlc,l;
     nu := numr u;
     du := denr u;
     a: if domainp nu or null(mvar nu eq 'pi) then return nil . u;
        if ldeg nu < (if domainp du then 1 else ldeg du + 1)
           then return nil . u;
        if ldeg nu = (if domainp du then 1 else ldeg du + 1)
           then <<if null l
                    then l := quotsq(lc nu ./ 1,
                                     (if domainp du then du else lc du) ./ 1)
                   else if quotsq(lc nu ./ 1,
                                  (if domainp du then du else lc du) ./ 1) neq l
                    then return nil . u;
                  if domainp du or null red du then return l . u;
                  du := red du>>;
        nu := red nu;
        go to a
  a: if domainp nu or mvar nu neq 'pi then return nil . u;
     ddeg := if domainp du or mvar nu neq 'pi then 0 else ldeg du;
     if ldeg nu <= ddeg then return nil . u;
     if ldeg nu = ddeg+1 then <<
          dlc := if domainp du then du else lc du;
          if null l
            then l := quotsq(lc nu ./ 1,dlc ./ 1)
           else if quotsq(lc nu ./ 1,dlc ./ 1) neq l
            then return nil . u;
          if domainp du or null red du then return l . u;
         du := red du>>;
      nu := red nu;
      go to a
   end;



M packages/misc/limits.red => packages/misc/limits.red +8 -5
@@ 176,7 176,8 @@ symbolic procedure limit0(exp,x,a);
              then mk!*sq y
           else if neq(a,0) then limit00(subsq(exp1,{x .
              {'plus,a,x}}),x)
           else limit00(exp1,x)>> where y=nil) end;
           else limit00(exp1,x)>> where y=nil)
   end;

%%
%% RmS: limit!-expcombine detects expressions of the form


@@ 276,8 277,9 @@ symbolic procedure pwrdenp(p,x);
   else lcm(pwrdenp(car p,x),pwrdenp(cdr p,x));

symbolic procedure limitset(ex,x,a);
 begin scalar result;
 begin scalar result,ex_in;
 if !*trlimit then <<
    ex_in := ex;
    prin2!* "Limit ("; prin2!* trlimitlevel!*; prin2!* "): Trying power series expansion using ";
   prin2!* if !*usetaylor then "Taylor w.r.t." else "TPS w.r.t.";
   mathprint x; prin2!* "around";


@@ 301,7 303,7 @@ symbolic procedure limitset(ex,x,a);
   if null result then << prin2!* "Limit ("; prin2!* trlimitlevel!*; prin2!* "): Expansion failed"; terpri!* t; >>
    else <<
     prin2!* "Limit ("; prin2!* trlimitlevel!*; prin2!* "): Power series expansion gives"; terpri!* t;
     mathprint result;
     mathprint {'replaceby,ex_in,result};
     >>;
 >>;
 return result


@@ 625,8 627,9 @@ symbolic procedure limfix(ex,x,a);
    where val=limitset(ex,x,a);

symbolic procedure limitest(ex,x,a);
   (begin scalar result;
   (begin scalar result,ex_in;
      if !*trlimit then <<
	 ex_in := ex;
	 prin2!* "Limit ("; prin2!* trlimitlevel!*; prin2!* "): Entering limitest for"; 
	 mathprint ex;
	 prin2!* "w.r.t. variable"; mathprint x;


@@ 645,7 648,7 @@ symbolic procedure limitest(ex,x,a);
    ret:
  if !*trlimit then <<
     prin2!* "Limit ("; prin2!* trlimitlevel!*; prin2!* "): limitest returns"; terpri!* t;
     mathprint result;
     mathprint {'replaceby,ex_in,result};
  >>;
  return result;
   end) where trlimitlevel!*=trlimitlevel!*+1;

M packages/misc/limits.tst => packages/misc/limits.tst +2 -0
@@ 224,6 224,8 @@ To make them all work it will be best to define a separate limit
evaluator, either to be used separately, or to be used when the present 
evaluator has failed.$

limit(x/(1+e^x),x,infinity);

limit((e+1)^(x^2)/e^x,x,infinity); % infinity
limit(e^x-e^(x-1/x^2),x,infinity); % infinity
limit(1/(e^x-e^(x-1/x^2)),x,infinity); % infinity

M packages/support/revision.red => packages/support/revision.red +1 -1
@@ 31,6 31,6 @@

fluid '(revision!*);

revision!* := 5854;
revision!* := 5863;

end;

M psl/dist/comp/dumpfasl.sl => psl/dist/comp/dumpfasl.sl +24 -8
@@ 1,10 1,9 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% File:         PC:DUMPFASL.SL 
% Title:        Code for showing some contents of a FASL file: symbols, relocation
% Author:       Rainer Sch�pf
% Created:      08 February 2019
% Modified:     
% Modified:     08 June 2021
% Status:       Open Source: BSD License
% Mode:         Lisp 
%


@@ 44,6 43,8 @@
  (prog (fid                  % file pointer 
	 local-id-count       % number of ids in the file
	 local-id-table       % table for mapping local ID numbers to global ID numbers.
	 readcount            % number of words in local-id-table
	 current-offset	      % current offset into input file
	 code-size            % number of words of code
	 code-base            % location of the start of the code
	 init-function-address% Offset into the code of the init function


@@ 53,6 54,7 @@
	 Btop
	 )

    (printf "Dumpfasl of file %s%n" file)
    % Open the file
    (setf fid (binaryopenread file))



@@ 64,21 66,30 @@
	(return nil)
	)
    (setq mode (wshift mode -16))
    (setq current-offset 1)

    % Read in the ID table.
    (setf local-id-table (dumpfasl-read-id-table fid))
    (setf (cons readcount local-id-table) (dumpfasl-read-id-table fid))
    (printf "ID table has size %d (%x) words%n" readcount readcount)
    (setq current-offset (plus2 current-offset readcount))

    % Read the code.
    (setf code-size (binaryread fid)) % Size of code segment in words
    (setf code-base (gtbps code-size)) % Allocate space in BPS
    (setq Btop (GtBPS 0))              % pointer to top of alloc. BPS
    (setf init-function-address (binaryread fid))
    (printf "Code has size %d (%x), init function at relative address %d (%x)%n"
	    code-size code-size init-function-address init-function-address)
    (setq current-offset (plus2 current-offset 2))
    (printf "Code has size %d (%x) words at offset %d (%x) words,%n init function at relative address %d (%x)%n"
	    code-size code-size
	    current-offset current-offset
	    init-function-address init-function-address)
    (binaryreadblock fid (loc (wgetv code-base 0)) code-size)
    (setq current-offset (plus current-offset code-size 2))

    % Read the bit table
    (setf bit-table-size (binaryread fid))
    (printf "Fasl bittable has size %d (%x) wirds%n" bit-table-size bit-table-size)
    (setq current-offset (plus2 current-offset bit-table-size))
    (setq bit-table (mkwrds (gtwrds bit-table-size)))
    (binaryreadblock fid (loc (words-fetch bit-table 0)) bit-table-size)



@@ 214,19 225,24 @@

  (let* ((local-id-count  (binaryread fid))
	 (id-table        (mkwrds (gtwrds (wplus2 local-id-count 1))))
	 x)
         (readcount 1)
	 x
	 n)

    (printf "ID table has %d entries:%n" local-id-count)
    (for 
     (from i 0 local-id-count)
     (do (setf (wgetv tokenbuffer 0) (binaryread fid)) % word is length of ID name
         (setq readcount (add1 readcount))
     	 (setq n (strpack (wgetv tokenbuffer 0)))
	 (binaryreadblock fid
			  (loc (wgetv tokenbuffer 1)) 
			  (strpack (wgetv tokenbuffer 0)))
			  n)
	 (setq readcount (plus2 readcount n))
	 (setq x (faslin-intern (mkstr (loc (wgetv tokenbuffer 0)))))
	 (printf "%d: %w - %d%n" i x (idinf x))
	 (setf (words-fetch id-table i) (idinf x))
	 ))
    id-table
    (cons readcount id-table)
    ))


D psl/dist/kernel/freeBSD/test.red => psl/dist/kernel/freeBSD/test.red +0 -82
@@ 1,82 0,0 @@
lisp; % praeludium

input!-case nil;
on comp;

smacro procedure sstrbase (x); wor( x + 4, lshift(1,27)); 

module xbegin1;

define!-constant(TCL_TRACE_WRITES,32);

procedure xbegin1();
   begin scalar interp;
      interp := Tcl_CreateInterp();
      Tcl_Init interp;
      Tk_Init interp;
      prin2t "Nach Initialisierung";
      CreateFrontend interp;
      prin2t "Vor MainLoop";
      Tcl_TraceVar(interp,sstrbase strinf "commandflag",TCL_TRACE_WRITES,
		sstrbase( (inf cdr getd 'ProcessCommand)-4),0); %HACK!!
      Tk_MainLoop();
      prin2t "Nach MainLoop";
      Tcl_DeleteInterp interp
   end;

procedure CreateFrontend(interp);
   Tcl_Eval(interp,sstrbase strinf "
frame .input -relief raised
entry .entry -width 64 -textvariable command -background white
bind .entry <Return> {
   set commandflag 1
   .text insert end ""$commandout\n""
   .text yview end
   .entry delete 0 end
}
pack .entry -side left -fill x -in .input -padx 1m -pady 1m
frame .output
text .text -bd 2 -yscrollcommand "".scroll set"" -background white
scrollbar .scroll -command "".text yview""
pack .text .scroll -side left -fill y -in .output -padx 1m
pack .input .output");

lap '((!*entry ProcessCommand expr 0) % a callback procedure from C!!
	(push (reg ebp))
	(!*move (displacement (reg st) 8) (reg 1))
	(!*move (displacement (reg st) 12) (reg 2))
	(!*move (displacement (reg st) 16) (reg 3))
	(!*move (displacement (reg st) 20) (reg 4))
	(!*move (displacement (reg st) 24) (reg 5))
	(!*link ProcessCommand_lisp expr 5)
	(pop (reg ebp))
	(ret));

fluid '(tclinputbuffer!* globinterp);

procedure ProcessCommand_lisp(dummy,interp,n1,n2,flags);
   begin scalar command,xr;
      command := Tcl_GetVar(interp,sstrbase strinf "command",255);
      command := importforeignstring command;
      wputv(unixstring2(tclinputbuffer!*),0,wgetv(unixstring2(command),0));
      copystringtofrom(tclinputbuffer!*,command);

 %%Tcl_SetVar(interp,sstrbase strinf "commandout", sstrbase strinf "->", 255);
      prin2t command;
      print (xr :=  xread(t));
globinterp := interp;
globliste := nil;
      mathprint (xr := aeval(xr));
 foreach ll in reverse globliste do
  if not (ll = "") then  
 Tcl_SetVar(interp,sstrbase strinf "commandout", sstrbase strinf ll, 255);
globinterp:= nil;
print globliste;
     return 0;
    end;

endmodule;
end;

load helferlein; in "$pxk/test.red"; algebraic;
 << lisp load "lap/tcl-sys-io"; lisp xbegin1()>>;

A psl/dist/lap/AMD64_ext/dumpfasl.b => psl/dist/lap/AMD64_ext/dumpfasl.b +0 -0
M psl/dist/lap/macintel64/hashtable.b => psl/dist/lap/macintel64/hashtable.b +0 -0
M psl/dist/psl-names.bash => psl/dist/psl-names.bash +2 -1
@@ 60,7 60,8 @@

scriptpath=$BASH_ARGV
scriptdir=`dirname $scriptpath`
export proot=`realpath $scriptdir/..`
cd $scriptdir/..; export proot=`pwd`; cd $OLDPWD
#export proot=`realpath $scriptdir/..`
#export proot=/mounts/software/rainer/reduce-algebra/code/trunk/psl

export psl=$proot/dist          # Top of PSL tree.

A psl/dist/util/armv6/mathlib.sl => psl/dist/util/armv6/mathlib.sl +648 -0
@@ 0,0 1,648 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% File:         PU: MATHLIB.SL 
% Description:  Some useful mathematical functions for PSL 
% Author:       Contributions from Galway, Griss, Irish, Morrison, and others 
% Created:      
% Modified:     02-Dec-83 18:07:29 (Nancy Kendzierski) 
% Mode:         Lisp 
% Package:      Utilities 
% Status:       Open Source: BSD License
% Notes:        
% Compiletime:  
% Runtime:      
%
% (c) Copyright 1983, Hewlett-Packard Company, see the file
%            HP_disclaimer at the root of the PSL file tree
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Revisions:
%
%  June 23 1991, Herbert Melenk
%    inserted calls for fp operations reusing boxes
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(compiletime (load useful))

%***************** Constants previously declared as NewNam's *****************
(fluid '(number2pi numberpi numberpi!/2 numberpi!/4 number3pi!/4
	 number!-2pi number!-pi number!-pi!/2 number!-pi!/4 number!-3pi!/4
	 numbere numberinversee naturallog2 naturallog10
	 sqrttolerance trigprecisionlimit))

(setq number2pi 6.2831853071795864770)
(setq numberpi 3.1415926535897932385)
(setq numberpi!/2 1.57079632679489661925)
(setq numberpi!/4 0.785398163397448309625)
(setq number3pi!/4 2.356194490192344928875)

% It's probably a mistake to have two definitions, with and without dashes...
(setq number!-2pi 6.2831853071795864770)
(setq number!-pi 3.1415926535897932385)
(setq number!-pi!/2 1.57079632679489661925)
(setq number!-pi!/4 0.785398163397448309625)
(setq number!-3pi!/4 2.356194490192344928875)

(setq numbere 2.71828182845904523536)
(setq numberinversee 0.367879441171442321596)	% 1/e
(setq naturallog2 0.6931471805599453094)
(setq naturallog10 2.302585092994045684)

(setq sqrttolerance 1.00000E-007)
(setq trigprecisionlimit 80)

%********************* Basic functions ***************************************
                                                                           
% Mathematically, mod(x,m) should be x-m*floor(x/m)
(de mod (x m)
  (let* ((pair (divide x m))
	 (q (car pair))
	 (r (cdr pair)))
    % Quotient in PSL division is always truncated toward 0.  We
    % adjust Q to be the "floor" of the true quotient.
    (if (and (lessp q 0) (not (equal r 0)))
      (setq q (sub1 q)))
    (difference x (times m q))))

(de floor (x)
  % Returns the largest integer less than or equal to X.  (I.e. the "greatest
  % integer" function.)                                                    
  (if (fixp x)
    x
    (prog (n)
          (setq n (fix x))
          % Note the trickiness to compensate for fact that (unlike APL's
          % "FLOOR" function) FIX truncates towards zero.
          (return (cond ((equal x (float n)) n)
                        ((geq x 0) n)
                        (t (difference n 1)))))))

(de ceiling (x)
  % Returns the smallest integer greater than or equal to X.               
  (if (fixp x)
    x
    (prog (n)
          (setq n (fix x))
          % Note the trickiness to compensate for fact that (unlike APL's
          % "FLOOR" function) FIX truncates towards zero.
          (return (cond ((equal x (float n)) n)
                        ((greaterp x 0) (plus n 1))
                        (t n))))))

(de round (x)
  % Rounds to the closest integer.                                         
  % Kind of sloppy -- it's biased when the digit causing rounding is a five,
                                                                           
  % it's a bit weird with negative arguments, round(-2.5)= -2.             
  (if (fixp x)
    x
    (floor (plus x 0.5))))

%***************** Trigonometric Functions ***********************************
                                                                           
% Trig functions are all in radians.  The following few functions may be used
                                                                           
% to convert to/from degrees, or degrees/minutes/seconds.                  
(de degreestoradians (x)
  (times x 0.0174532925199432957694))		% 2*pi/360

(de radianstodegrees (x)
  (times x 57.2957795130823208761))		% 360/(2*pi)

% 360/(2*pi)                                                               
(de radianstodms (x)
  % Converts radians to a list of degrees, minutes, and seconds (rounded, not
                                                                           
  % truncated, to the nearest integer).                                    
  (prog (degs mins)
        (setq x (radianstodegrees x))
        (setq degs (fix x))
        (setq x (times 60 (difference x degs)))
        (setq mins (fix x))
        (return (list degs mins (round (times 60 (difference x mins)))))))

(de dmstoradians (degs mins sex)
  % Converts degrees, minutes, seconds to radians.                         
  (degreestoradians
   (plus degs (quotient mins 60.0) (quotient sex 3600.0))))

(de sin (x)
  % Accurate to about 6 decimal places, so long as the argument is         
  % of commensurate precision.  This will, of course, NOT be true for      
  % large arguments, since they will be coming in with small precision.    
  (prog (neg)
        (when (minusp x)
          (setq neg t)
          (setq x (minus x)))
        (when (greaterp x numberpi)
          (setq x 
                (difference x 
                 (times number2pi 
                        (fix (quotient (plus x numberpi) number2pi))))))
        (when (minusp x)
          (setq neg (not neg))
          (setq x (minus x)))
        (when (greaterp x numberpi!/2)
          (setq x (difference numberpi x)))
        (return (if neg
                  (minus (scaledsine x))
                  (scaledsine x)))))

(de scaledsine (x)
  % assumes its argument is scaled to between 0 and pi/2.                  
  (prog (xsqrd)
        (setq x (plus x 0.0)) % now x is float and a fresh box
        (setq xsqrd (floattimes2 x x))
        (return (==iptimes2 x 
                       (==ipplus2r 1.0 
                        (==iptimes2r xsqrd 
                         (==ipplus2r -0.1666666664 
                          (==iptimes2r xsqrd 
                           (==ipplus2r 0.0083333315 
                            (==iptimes2r xsqrd 
                             (==ipplus2r -0.0001984090
                              (==iptimes2r xsqrd 
                               (==ipdifferencer 0.0000027526
                                (floattimes2 xsqrd 0.0000000239))))))))))))))

(de cos (x)
  % Accurate to about 6 decimal places, so long as the argument is         
  % of commensurate precision.  This will, of course, NOT be true for      
  % large arguments, since they will be coming in with small precision.    
  (progn (when (minusp x)
           (setq x (minus x)))
         (when (greaterp x numberpi)
           (setq x 
                 (difference x 
                  (times number2pi 
                         (fix (quotient (plus x numberpi) number2pi))))))
         (when (minusp x)
           (setq x (minus x)))
         (if (greaterp x numberpi!/2)
           (minus (scaledcosine (difference numberpi x)))
           (scaledcosine x))))

(de scaledcosine (x)
  % Expects its argument to be between 0 and pi/2.                         
  (prog (xsqrd)
        (setq x (plus x 0.0)) % now x is float and a fresh box
        (setq xsqrd (times x x))
        (return (==ipplus2r 1.0  
                      ( ==iptimes2r xsqrd 
                       (==ipplus2r -0.5 
                        (==iptimes2r xsqrd 
                         (==ipplus2r 0.041666642
                          (==iptimes2r xsqrd 
                           (==ipplus2r -0.0013888397
                            (==iptimes2r xsqrd 
                             (==ipdifferencer 0.0000247609
                              (times xsqrd 0.0000002605)))))))))))))

(de tan (x)
  % Accurate to about 6 decimal places, so long as the argument is         
  % of commensurate precision.  This will, of course, NOT be true for      
  % large arguments, since they will be coming in with small precision.    
  (prog (neg)
        (when (minusp x)
          (setq neg t)
          (setq x (minus x)))
        (when (greaterp x numberpi!/2)
          (setq x 
                (difference x 
                 (times numberpi 
                        (fix (quotient (plus x numberpi!/2) numberpi))))))
        (when (minusp x)
          (setq neg (not neg))
          (setq x (minus x)))
        (if (lessp x numberpi!/4)
          (setq x (scaledtangent x))
          (setq x (scaledcotangent (minus (difference x numberpi!/2)))))
        (return (if neg
                  (minus x)
                  x))))

(de cot (x)
  % Accurate to about 6 decimal places, so long as the argument is         
  % of commensurate precision.  This will, of course, NOT be true for      
  % large arguments, since they will be coming in with small precision.    
  (prog (neg)
        (when (minusp x)
          (setq neg t)
          (setq x (minus x)))
        (when (greaterp x numberpi!/2)
          (setq x 
                (difference x 
                 (times numberpi 
                        (fix (quotient (plus x numberpi!/2) numberpi))))))
        (when (minusp x)
          (setq neg (not neg))
          (setq x (minus x)))
        (if (lessp x numberpi!/4)
          (setq x (scaledcotangent x))
          (setq x (scaledtangent (minus (difference x numberpi!/2)))))
        (return (if neg
                  (minus x)
                  x))))

(de scaledtangent (x)
  % Expects its argument to be between 0 and pi/4.                         
  (prog (xsqrd)
        (setq x (plus x 0.0)) % now x is float and a fresh box
        (setq xsqrd (floattimes2 x x))
        (return (==iptimes2 x 
                       (==ipplus2r 1.0 
                        (==iptimes2r xsqrd 
                         (==ipplus2r 0.3333314
                          (==iptimes2r xsqrd 
                           (==ipplus2r 0.1333924 
                            (==iptimes2r xsqrd 
                             (==ipplus2r 0.05337406 
                              (==iptimes2r xsqrd 
                               (==ipplus2r 0.024565089 
                                (==iptimes2r xsqrd 
                                 (==ipplus2r 0.002900525
				  (floattimes2 xsqrd 0.0095168091))))))))))))))))

(de scaledcotangent (x)
  % Expects its argument to be between 0 and pi/4.                         
  (prog (xsqrd)
        (setq x (plus x 0.0)) % now x is float and a fresh box
        (setq xsqrd (floattimes2 x x))
        (return (==ipquotient 
                 (==ipdifferencer 1.0 
                  (==iptimes2r xsqrd 
                         (==ipplus2r 0.33333334
                          (==iptimes2r xsqrd 
                           (==ipplus2r 0.022222029
                            (==iptimes2r xsqrd 
                             (==ipplus2r 0.0021177168
                              (==iptimes2r xsqrd 
                               (==ipplus2r 0.0002078504
				(floattimes2 xsqrd 0.0000262619))))))))))
                 x))))

(de sec (x)
  (quotient 1.0 (cos x)))

(de csc (x)
  (quotient 1.0 (sin x)))

(de sind (x)
  (sin (degreestoradians x)))

(de cosd (x)
  (cos (degreestoradians x)))

(de tand (x)
  (tan (degreestoradians x)))

(de cotd (x)
  (cot (degreestoradians x)))

(de secd (x)
  (sec (degreestoradians x)))

(de cscd (x)
  (csc (degreestoradians x)))

(de asin (x)
  (prog (neg)
        (when (minusp x)
          (setq neg t)
          (setq x (minus x)))
        (when (greaterp x 1.0)
          (stderror (list "Argument to ASIN too large:" x)))
        (return (if neg
                  (difference (checkedarccosine x) numberpi!/2)
                  (difference numberpi!/2 (checkedarccosine x))))))

(de acos (x)
  (prog (neg)
        (when (minusp x)
          (setq neg t)
          (setq x (minus x)))
        (when (greaterp x 1.0)
          (stderror (list "Argument to ACOS too large:" x)))
        (return (if neg
                  (difference numberpi (checkedarccosine x))
                  (checkedarccosine x)))))

(de checkedarccosine (x)
  % Return cosine of a "checked number", assumes its argument is in the range
                                                                           
  (setq x (float x))
  % 0 <= x <= 1.                                                           
  (==iptimes2 (sqrt (difference 1.0 x)) 
   (==ipplus2r 1.5707963
         (==iptimes2r x 
                (==ipplus2r -0.2145988
                      (==iptimes2r x 
                       (==ipplus2r 0.088978987
                        (==iptimes2r x 
                         (==ipplus2r -0.050174305
                          (==iptimes2r x 
                           (==ipplus2r 0.030891881
                            (==iptimes2r x 
                             (==ipplus2r -0.017088126
                              (==iptimes2r x 
                               (==ipdifferencer 0.0066700901
				(floattimes2 x 0.0012624911))))))))))))))))

(de atan (x)
  (cond ((minusp x) (if (lessp x -1.0)
           (plus number!-pi!/2 (checkedarctangent (quotient -1.0 x)))
           (minus (checkedarctangent (minus x)))))
        ((greaterp x 1.0) 
         (difference numberpi!/2 (checkedarctangent (quotient 1.0 x))))
        (t (checkedarctangent x))))

(de acot (x)
  (cond ((minusp x) (if (lessp x -1.0)
           (minus (checkedarctangent (quotient -1.0 x)))
           (plus number!-pi!/2 (checkedarctangent (minus x)))))
        ((greaterp x 1.0) (checkedarctangent (quotient 1.0 x)))
        (t (difference numberpi!/2 (checkedarctangent x)))))

(de checkedarctangent (x)
  (prog (xsqrd)
        (setq x (plus x 0.0))
        (setq xsqrd (times x x))
        (return 
         (==iptimes2r x 
          (==ipplus2r 1.0 
           (==iptimes2r xsqrd 
            (==ipplus2r -0.33333145
                  (==iptimes2r xsqrd 
                         (==ipplus2r 0.19993551
                          (==iptimes2r xsqrd 
                           (==ipplus2r -0.14208899 
                            (==iptimes2r xsqrd 
                             (==ipplus2r 0.10656264
                              (==iptimes2r xsqrd 
                               (==ipplus2r -0.07528964 
                                (==iptimes2r xsqrd 
                                 (==ipplus2r 0.042909614
                                  (==iptimes2r xsqrd 
                                   (==ipplus2r -0.016165737
				    (times xsqrd 0.0028662257))))))))))))))))))))

(de asec (x)
  (acos (quotient 1.0 x)))

(de acsc (x)
  (asin (quotient 1.0 x)))

(de asind (x)
  (radianstodegrees (asin x)))

(de acosd (x)
  (radianstodegrees (acos x)))

(de atand (x)
  (radianstodegrees (atan x)))

(de acotd (x)
  (radianstodegrees (acot x)))

(de asecd (x)
  (radianstodegrees (asec x)))

(de acscd (x)
  (radianstodegrees (acsc x)))

%****************** Roots and such *******************************************
                                                                           
%    Fast SQRT using access to IEEE exponent
%    for initial guess and (partially) unboxed
%    arithmetic for the Newton iterations.

(compiletime
   (define-constant IEEEbias 1023)
)

(compiletime (flag1 'initialsqrt 'internalfunction))
(compiletime (load inum))

(de initialsqrt(x)
   % initial approximation for sqrt: divide exponent by 2
   % sqrt(m*2**e)-> m*2**(e/2)
  (prog(e m ho)
   (setq x (floatplus2 x 0.0))  % new box with same number
      % pick out exponent and divide by 2
   (setq ho (floatHighorder (inf x)))
   (setq e  (wdifference (wand 2#11111111111 (wshift ho -20))
                        IEEEbias))
   (setq e (wplus2 IEEEbias (wshift e -1)))
      % eliminate old exponent
   (setq m (wminus (wshift 2#11111111111 20)))
   (setq ho (wand m ho))
      % insert new exponent
   (setq ho (wor (wshift e 20)))
   (setf (floatHighorder (inf x)) ho)
   (return x) ))

(de sqrt(x)
   % Newton iteration for fixpoint of y**2-x;
   % start with a good initial approximation and
   % then do 4 steps without further reasoning.
   (prog(a)
    (setq x (float x))
    (cond((floatlessp x 0.0) (stderror "sqrt called with negative argument"))
         ((zerop x)(return 0.0)))
    (setq a (initialsqrt x))
    (ifor (from i 1 4 1)
          (do
        % a := a - (a^2 - x)/2a
     (setq a
      (==ipdifference
          a
          (==ipquotient
              (==ipdifference
                 (floattimes2 a a)
                 x)
              (floatplus2 a a) )))) )
    (return a) ))

%******************** Logs and Exponentials **********************************
                                                                           
(de exp (x)
  % Returns the exponential (ie, e**x) of its floatnum argument as         
  % a flonum. The argument is scaled to                                    
  % the interval -ln  2 to  0, and a  Taylor series  expansion             
  % used (formula 4.2.45 on page 71 of Abramowitz and  Stegun,             
  % "Handbook of Mathematical  Functions").                                
  (prog (n)
        (setq n (ceiling (quotient x naturallog2)))
        (setq x (difference (times n naturallog2) x))
        (return 
         (times (expt 2.0 n) 
          (==ipplus2r 1.0 
                (==iptimes2r x 
                       (==ipplus2r -0.9999999995
                        (==iptimes2r x 
                         (==ipplus2r 0.4999999206
                          (==iptimes2r x 
                           (==ipplus2r -0.1666653019
                            (==iptimes2r x 
                             (==ipplus2r 0.0416573475 
                              (==iptimes2r x 
                               (==ipplus2r -0.0083013598 
                                (==iptimes2r x 
                                 (==ipplus2r 0.0013298820
				 (floattimes2 x -0.0001413161))))))))))))))))))

(de log (x)
  % See Abramowitz and Stegun, page 69.                                    
  (cond ((leq x 0.00000E+000) 
         (stderror (list "LOG given non-positive argument:" x)))
        ((lessp x 1.0) (minus (log (quotient 1.0 x))))
        (t % Find natural log of x > 1;                                     
           (prog (nextx ipart)
                 % ipart is the "integer part" of the                      
                 % logarithm.                                              
                 (setq ipart 0)
                 % Keep multiplying by 1/e until x is small enough, may want
                 % to be more "efficient" if we ever use really big numbers.
                 (while (greaterp (setq nextx (times numberinversee x)) 
                         1.0)
                   (setq x nextx)
                   (setq ipart (plus ipart 1))
                   nil)
                 (return (plus ipart (if (lessp x 2.0)
                            (checkedlogarithm x)
                            (times 2.0 (checkedlogarithm (sqrt x))))))))))

(de checkedlogarithm (x)
  % Should have 1 <= x <= 2.  (i.e. x = 1+y  0 <= y <= 1)                  
  (progn (setq x (difference x 1.0))
         (==iptimes2r x 
          (==ipplus2r 0.99999642
                (==iptimes2r x 
                       (==ipplus2r -0.49987412 
                        (==iptimes2r x 
                         (==ipplus2r 0.33179903
                          (==iptimes2r x 
                           (==ipplus2r -0.24073381
                            (==iptimes2r x 
                             (==ipplus2r 0.16765407
                              (==iptimes2r x 
                               (==ipplus2r -0.09532939 
                                (==iptimes2r x 
                                 (==ipdifferencer 0.036088494
				  (times x 0.0064535442)))))))))))))))))

(de log2 (x)
  (quotient (log x) naturallog2))

(de log10 (x)
  (quotient (log x) naturallog10))

%********************* Random Number Generator *******************************
                                                                           
% The declarations below  constitute a linear,  congruential               
% random number generator (see  Knuth, "The Art of  Computer               
% Programming: Volume 2: Seminumerical Algorithms", pp9-24).               
% With the given  constants it  has a period  of 392931  and               
% potency  6.    To   have  deterministic   behaviour,   set               
% RANDOMSEED.                                                              
%                                                                          
% Constants are:        6   2                                              
%    modulus: 392931 = 3 * 7 * 11                                          
%    multiplier: 232 = 3 * 7 * 11 + 1                                      
%    increment: 65537 is prime                                             
%                                                                          
% Would benefit from being recoded in SysLisp, when full word integers should
% be used with "automatic" modular arithmetic (see Knuth).  Perhaps we should
% have a longer period version?                                            
% By E. Benson, W. Galway and M. Griss                                     
(fluid '(randomseed randommodulus))

(setq randommodulus 392931)

(setq randomseed (remainder (time) randommodulus))

(de next!-random!-number ()
  % Returns a pseudo-random number between 0 and RandomModulus-1 (inclusive).
                                                                           
  (setq randomseed 
        (remainder (plus (times 232 randomseed) 65537) randommodulus)))

(de random (n)
  % Return a pseudo-random number uniformly selected from the range 0..N-1.
  % NOTE that this used to be called RandomMod(N).  Needs to be made more  
  % compatible with Common LISP's random?                                  
  (fix (quotient (times (float n) (next!-random!-number)) randommodulus)))

(de factorial (n)
  % Simple factorial                                                       
  (prog (m)
        (setq m 1)
        (for (from i 1 n 1) (do (setq m (times m i))))
        (return m)))

% Some functions from ALPHA_1 users                                        
(de atan2d (y x)
  (radianstodegrees (atan2 y x)))

(de atan2 (y x)
  (setq x (float x))
  (setq y (float y))
  (cond ((equal x 0.00000E+000) % Y axis.
	 (if (geq y 0.00000E+000)
           numberpi!/2
           (plus numberpi numberpi!/2)))
        ((and (geq x 0.00000E+000) (geq y 0.00000E+000)) % First quadrant.  
         (atan (quotient y x)))
        ((and (lessp x 0.00000E+000) (geq y 0.00000E+000)) % Second quadrant.
         (difference numberpi (atan (quotient y (minus x)))))
        ((and (lessp x 0.00000E+000) (lessp y 0.00000E+000)) % Third quadrant.
         (plus numberpi (atan (quotient y x))))
        (t % Fourth quadrant.                                               
           (difference number2pi (atan (quotient (minus y) x))))))

(de transfersign (s val)
  % Transfers the sign of S to Val by returning abs(Val) if S >= 0,        
  % otherwise -abs(Val).                                                   
  (if (geq s 0)
    (abs val)
    (minus (abs val))))

(de dmstodegrees (degs mins sex)
  % Converts degrees, minutes, seconds to degrees                          
  (plus degs (quotient mins 60.0) (quotient sex 3600.0)))

(de degreestodms (x)
  % Converts degrees to a list of degrees, minutes, and seconds (all integers,
  % rounded, not truncated).                                               
  (prog (degs mins)
        (setq degs (fix x))
        (setq x (times 60 (difference x degs)))
        (setq mins (fix x))
        (return (list degs mins (round (times 60 (difference x mins)))))))


A psl/dist/util/armv6/stringio.sl => psl/dist/util/armv6/stringio.sl +126 -0
@@ 0,0 1,126 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% File:         PNK:STRINGIO.SL 
% Title:        File primitives 
% Author:       Eric Benson 
% Created:      27 August 1981 
% Modified:     31-May-84 10:46:09 (Brian Beach) 
% Status:       Open Source: BSD License
% Mode:         Lisp 
% Package:      Kernel 
% Compiletime:  PL:IO-DECLS.B 
% Runtime:      
%
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(on fast-integers)

(de stringopen(string len)

  (prog (filedes)
   (setq filedes (systemopenstring string))
   (setf (wgetv lineposition filedes) 0)
   (setf (wgetv maxline filedes) len)
   (setf (wgetv unreadbuffer filedes) (char null))
   (setf (wgetv readfunction filedes)  'independentreadchar_from_string)
   (setf (wgetv writefunction filedes) 'independentwritechar_to_string)
   (setf (wgetv closefunction filedes) 'independentclosestring)
   (setf (wgetv nextposition  filedes) 0)   % Will be post Incremented
   (setf (wgetv bufferlength  filedes) len)
   (setf (wgetv maxbuffer filedes) len)
   (setf (igetv iobuffer  filedes) (mkstr string))

  (return  filedes)))


(de systemopenstring (string)
 
  %  Mark a a pair of channels as open for a special purpose.
 
  (let ((channel (findfreechannel)))
    (setf (wgetv channelstatus channel) 'channelopenspecial)
    (setf (wgetv channeltable  channel) string)
    channel
    ))
 
(de independentclosestring (channel)

  (testlegalchannel channel)
  (setf (wgetv channeltable channel) 'channelclosed)
  )

(de independentwritechar_to_string (channel chr)

  % Write a character into the buffer.  Actually dump the buffer when the
  % EOL character is found, or when the buffer is full.  This happens
  % immediately upon meeting this condition, not waiting for the
  % next character.  Note, that this places the EOL character into the
  % buffer for machine dependent treatment as CR/LF etc

  (testlegalchannel channel)
  (setf (wgetv nextposition channel) (+ (wgetv nextposition channel) 1))
  (setf (strbyt (strinf (igetv iobuffer channel))
                (wgetv nextposition channel))
    chr)
)
(de independentreadchar_from_string (channel)

  % This function will read in a character from the buffer.  It will read
  % the record on buffer length overflow only.  Thus when an EOL character
  % is read, it is processed as any other character, except, if it is the last
  % one, in the record, it will do the read automatically.
  % Note, this will not read the next record until after the final character
  % has been processed.

  (testlegalchannel channel)

  % Pull the next character out of the buffer.

  (let ((chr (strbyt (strinf (igetv iobuffer channel))
                     (wgetv nextposition channel))))
    (setf (wgetv nextposition channel) (+ (wgetv nextposition channel) 1))
    (when *echo (writechar chr))
    chr
    ))

(off fast-integers)

lisp; on comp; load "$pl/stringio";

symbolic procedure terpri(); channelprin2(out!*, !$eol!$);
symbolic procedure terpri!*(ttt); nil;
off nat;
symbolic procedure reduceup(x,y,xx,yy);
 << x := mkstr x;
    y := mkstr y;
    rds stringopen (x ,xx);
    wrs stringopen (y ,yy);
    begin1();
    rds nil;
    wrs nil;
 >>;
os_cleanup_hook 17;



A psl/dist/util/armv6/vfvect.sl => psl/dist/util/armv6/vfvect.sl +253 -0
@@ 0,0 1,253 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% File:         PXU:VFVECT.SL
% Description:  very fast vector access                                  
% Author:       H. Melenk
% Created:      25 January 1989
% Modified:
% Mode:         Lisp
% Package:      Utilities
% Status:       Open Source: BSD License
%
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  this file is needed compiletime only
%
% This file defines a macro VFOR which has the same syntax as IFOR.
% The basic difference is that VFOR looks into the body to be executed
% and replaces all vector accesses via IgetV and IputV by references to   
% explicitly calculated addresses.                                           
(fluid '(*second-value* *variables*))
(fluid '(veccis gettis)) 

(dm vfor(u)
   (prog (vars body cvar veccis gettis by from to lvars pvars zvars let
          cvars *variables*)
          (setq from (append (assoc 'from u) '(1)))
          (setq by (caddr(cddr from)))
          (setq to (cadddr from))
          (setq cvar (cadr from))  % control variable
          (setq cvars (list cvar))
          (setq from (caddr from))
          (setq body (assoc 'do u))
          (when (null body)
                (comperr "******* do clause missing in vfor expansion"))
          (setq body (cadr body))  % strip off tag 'DO
          (setq let (assoc 'let u))
          (when let (setq let (cdr let))
                (setq cvars (cons (car let) cvars))
                (setq body (subst (cadr let) (car let) body))
                (extract-variables (cadr let))
                (setq *variables* (delete cvar *variables*)))
          (select-putv/getv body cvar)
          (setq zvars (mapcar gettis (function
               (lambda (x) (cons x (gensym))))))
          (setq pvars (cons cvar (mapcar zvars (function cdr))))
          (when let (setq pvars (cons (car let) pvars)))
                
               % case 1: from is a number
         (when (numberp from)
          (return 
          `(prog ,pvars
               (setq ,cvar ,from)
               (progn . ,(mapcar zvars
                           (function (lambda (x)
                              `(setq ,(cdr x)
                                ,(vfor-simp 
                                `(iplus2 (inf ,(caar x))
                                    (itimes2 addressingunitsperitem
                                       (iplus2 ,(subst from cvar (cdar x))
                                                1)))))))))

               ***loop***
               ,(if (greaterp by 0)
                    `(cond((igreaterp ,cvar ,to)(return NIL)))
                    `(cond((ilessp ,cvar ,to)(return NIL))))
               ,(reform-vfor body zvars)
               (progn . ,(mapcar zvars 
                           (function (lambda (x)
                              `(setq ,(cdr x)  
                               ,(vfor-simp 
                                ` (iplus2 ,(cdr x)
                                    (itimes2 addressingunitsperitem
                                       (idifference
                                          ,(subst by cvar (cdar x))
                                          ,(subst 0 cvar (cdar x))
                      )))))))))
               (setq ,cvar (iplus2 ,cvar ,by))
               (go ***loop***))))
               % case 2: from is an arbitrary expression
          (return
          `(prog ,pvars
               (setq ,cvar ,from)
               (progn . ,(mapcar zvars 
                           (function (lambda (x) 
                              `(setq ,(cdr x) 
                               ,(vfor-simp
                                `(iplus2 (inf ,(caar x)) 
                                    (itimes2 addressingunitsperitem 
                                       (iplus2 ,(subst from cvar (cdar x))
                                                1)))))))))
               ***loop***
               ,(if (greaterp by 0) 
                    `(cond((igreaterp ,cvar ,to)(return NIL))) 
                    `(cond((ilessp ,cvar ,to)(return NIL))))
               ,(reform-vfor body zvars)
               (progn . ,(mapcar zvars  
                           (function (lambda (x) 
                              `(setq ,(cdr x)   
                               ,(vfor-simp
                                `(iplus2 ,(cdr x) 
                                    (itimes2 addressingunitsperitem 
                                      (idifference 
                                          ,(subst by cvar (cdar x))
                                          ,(subst 0 cvar (cdar x)) 
                      )))))))))
               (setq ,cvar (iplus2 ,cvar ,by))
               (go ***loop***)))

))
 
(de select-putv/getv(form var)
   (cond ((atom form) nil)
         ((and (eqcar form 'iputv) (dependsof (caddr form) var))
          (setq gettis (union gettis (list (cons (cadr form) (caddr form)))))
          (select-putv/getv (cadddr form) var))
         ((and (eqcar form 'igetv) (dependsof (caddr form) var)) 
          (setq gettis (union gettis (list (cons (cadr form) (caddr form))))))
         (t (mapc form (function (lambda(x)(select-putv/getv x var)))))))
 
(de reform-vfor(form lvars)
    (cond ((atom form) form)
         ((and (eqcar form 'iputv)(assoc (cons (cadr form)(caddr form)) lvars))
          `(putmem ,(cdr (assoc (cons (cadr form)(caddr form)) lvars)) 
                   ,(reform-vfor (cadddr form) lvars)))
         ((and (eqcar form 'igetv)(assoc (cons (cadr form)(caddr form)) lvars))
          `(getmem ,(cdr (assoc (cons (cadr form)(caddr form)) lvars))))
         (t (mapcar form (function (lambda(x)(reform-vfor x lvars))))))) 


(de dependsof(form var)
   % test if the form depends only linearly from var
      (cond ((equal form var)t)
            ((numberp form) t)
            ((memq form *variables*) t)
            ((and (atom form) (get form 'constant?)(numberp (eval form))) T)
            ((atom form) nil)
            ((eqcar form 'iplus2)(and (dependsof (cadr form) var)
                                      (dependsof (caddr form) var)))
            ((eqcar form 'idifference)(and (dependsof (cadr form) var)
                                      (dependsof (caddr form) var)))
            ((eqcar form 'itimes2)
             (or (and (dependsof (cadr form) nil)
                      (dependsof (caddr form) var))
                 (and (dependsof (cadr form) nil) 
                      (dependsof (caddr form) var))))
            ((memq (car form) '(iadd1 isub1)) (dependsof (cadr form) var))
            (T nil)))

(de extract-variables(u)
   % extract the variables from an expression
      (cond ((null u) *variables*)
            ((numberp u) *variables*)
            ((pairp u) (mapc (cdr u) (function extract-variables)) *variables*)
            ((get u 'constant?) *variables*)
            (t (setq *variables* (union (cons u nil) *variables*)))))
 
(fluid '(*ioperators))
(setq *ioperators '((iplus2 . plus2)(idifference . difference)
                    (itimes2 . times2)(iquotient . quotient)
                    (isub1 . sub1)(iadd1 . add1)))

(de vfor-simp (u)
   % simplify an arithmetic expression based on i-operations
   (cond ((null u) nil)
         ((numberp u) u)
         ((get u 'constant?) (eval u))
         ((atom u) u)
         ((null (assoc (car u) *ioperators)) u)
         (T (prog (o x y h)
                (setq o (car u))
                (when (cdr u) (setq x (vfor-simp (cadr u)))
                      (when (cddr u) (setq y(vfor-simp  (caddr u)))))
                (when (and (eq o 'idifference) (numberp y))
                      (setq o 'iplus2)(setq y (minus y)))
                (when (and (numberp x)(numberp y))
                      (return (apply (cdr (assoc o *ioperators))
                                     (list x y))))
                (when (and (memq o '(itimes2 iplus2)) (numberp x))
                      (setq h x)(setq x y)(setq y h))
                (setq u(list o x y))
                (while (setq h (vfor-pat u)) (setq u (vfor-simp h)))
                (return u)))))
 
(fluid '(vfor-patterns*))
(setq vfor-patterns* '(
     ( (iadd1 *a nil)(iplus2 *a 1))
     ( (isub1 *a nil)(iplus2 *a -1))
     ( (iplus2 (iplus2 *a *n)(iplus2 *b *m))
       (iplus2 (iplus2 *a *b)(iplus2 *n *m)))
     ( (iplus2 (iplus2 *a *n) *m) (iplus2 *a (iplus2 *n *m)))
     ( (iplus2 *a 0) *a)
     ( (iplus2 *n *m)(eval (plus *n *m)))
     ( (idifference *a 0) *a)
     ( (idifference *a *a) 0)
     ( (idifference *a (iplus2 *a *n)) (iminus *n))
     ( (idifference (iplus2 *a *n) *b) (idifference *a (iplus2 *b(iminus *n))))
     ( (idifference (idifference *a *b) (idifference *a *c))
       (idifference *c *b))
     ( (idifference (iplus2 *a *b) *a)  *b)
     ( (iminus *n) (eval (minus *n)))
     
))

(de vfor-pat (u)
    (prog (p q)
         (setq p vfor-patterns*)
  loop   (when (null p)(return nil))
         (setq q(vfor-match u (caar p) (list nil)))
         (when q (setq q (subla q (cadar p)))
                 (when (eqcar q 'eval)
                       (setq q (eval (cadr q))))
                 (return q))
         (setq p (cdr p))
         (go loop)))
 
(de vfor-match(u pat a)
     (cond ((equal u pat) a)
           ((memq pat '(*a *b *c *d *n *m)) (vfor-match-variable u pat a))
           ((or (atom u) (atom pat))nil)
           ((setq a (vfor-match (car u)(car pat) a))
                    (vfor-match (cdr u)(cdr pat) a))))
 
(de  vfor-match-variable(u pat a) 
     (cond ((null (assoc pat a))  % not yet bound 
            (cond ((or (not (memq pat '(*n *m))) (numberp u))
                   (nconc a (list (cons pat u))))
                  (T nil)))
           ((equal (cdr (assoc pat a)) u) a)
           (T nil)))



M web/htdocs/web-reduce/DerivativeTemplate.inc => web/htdocs/web-reduce/DerivativeTemplate.inc +5 -5
@@ 13,12 13,12 @@
            <a href="/manual-lookup.php?DF%20Operator" target="_blank" title="Opens in a new tab.">DF Operator</a></small>
				</p>
				<div class="container-fluid">
					<div class="mx-auto" style="width: 200px;">
						<div class="center">
							∂<sup></sup>
							<input type="text" size="18" value="ws" />
					<div class="mx-auto" style="width: 15rem;">
						<div class="text-center">
							∂ <sup></sup>
							<input type="text" size="21" value="ws" />
						</div>
						<div class="center" style="margin-top: 5px; border-top: thin solid black; padding-top: 5px;">
						<div class="text-center" style="margin-top: 5px; border-top: thin solid black; padding-top: 5px;">
							∂<input type="text" size="1" data-index="0" value="x" /><sup><input type="text" size="1" data-index="0" style="font-style: normal" /></sup>
							∂<input type="text" size="1" data-index="1" /><sup><input type="text" size="1" data-index="1" style="font-style: normal" /></sup>
							∂<input type="text" size="1" data-index="2" /><sup><input type="text" size="1" data-index="2" style="font-style: normal" /></sup>

M web/htdocs/web-reduce/IntegralTemplate.inc => web/htdocs/web-reduce/IntegralTemplate.inc +8 -8
@@ 14,18 14,18 @@
				</p>
				<div class="container-fluid" style="text-align: center">
					<div style="display: inline-block; vertical-align: middle">
						<input type="text" size="3" /><br />
						<span style="font-size: 300%; color: red">∫</span><br />
						<input type="text" size="3" />
						<div style="margin-top: -1rem; font-size: 300%; color: red">∫</div>
						<input type="text" size="3" />
					</div>
					<div style="display: inline-block; vertical-align: middle">
						<input type="text" size="3" /><br />
						<span style="font-size: 300%; color: green">∫</span><br />
						<input type="text" size="3" />
						<div style="margin-top: -1rem; font-size: 300%; color: green">∫</div>
						<input type="text" size="3" />
					</div>
					<div style="display: inline-block; vertical-align: middle">
						<input type="text" size="3" /><br />
						<span style="font-size: 300%; color: blue">∫</span><br />
						<input type="text" size="3" />
						<div style="margin-top: -1rem; font-size: 300%; color: blue">∫</div>
						<input type="text" size="3" />
					</div>
					<input type="text" size="25" value="ws" />


@@ 109,8 109,8 @@
				const intVar = intVarTextFields[i].value.trim();
				if (intVar.length != 0) {
					text = "int(" + text;
					const lowLim = limTextFields[i][0].value.trim();
					const upLim = limTextFields[i][1].value.trim();
					const lowLim = limTextFields[i][1].value.trim();
					const upLim = limTextFields[i][0].value.trim();
					const indefInt = (lowLim.length == 0);
					if ((indefInt) != (upLim.length == 0)) {
						// boolean != is equivalent to exclusive or.

D web/htdocs/web-reduce/StyleSheet.css => web/htdocs/web-reduce/StyleSheet.css +0 -15
@@ 1,15 0,0 @@
body {
    max-width: 800px;
    margin: 0 auto;
    font-family: "Lucida Sans", "Lucida Sans Regular", "Lucida Grande", "Lucida Sans Unicode", Geneva, Verdana, sans-serif;
}
h1 {
    text-align: center;
    font-family: Georgia, "Times New Roman", Times, serif;
}
code {
    font-size: 140% !important;
}
.center {
    text-align: center;
}

A web/htdocs/web-reduce/UserGuide.php => web/htdocs/web-reduce/UserGuide.php +245 -0
@@ 0,0 1,245 @@
<?php
$page_title = 'Web REDUCE User Guide';
$header_title = 'Web REDUCE User Guide';
include '../include/begin-head.php';
include '../include/begin-body.php';
?>
<h2>Contents</h2>
<ul>
    <li><a href="#MainPage">The Main Page</a></li>
    <li><a href="#ViewMenu">The View Menu</a></li>
    <li><a href="#TemplatesMenu">The Templates Menu</a></li>
    <li><a href="#FunctionsMenu">The Functions Menu</a></li>
    <li><a href="#HelpMenu">The Help Menu</a></li>
</ul>

<h2 id="MainPage">The Main Page</h2>

<p>
    Web REDUCE starts loading as soon as its main page is opened and
    starts running as soon as it has loaded, which should be almost
    instantaneous except for the first time you run it or after an
    update to the Web REDUCE engine, in which case there may be a
    noticeable pause.  Web REDUCE will stop when you close its main
    page; it is not necessary to explicitly terminate REDUCE.  To
    restart Web REDUCE just reload its main page.
</p>
<p>
    The Web REDUCE main page consists of a menu bar and two panes, one
    above the other.  The top pane displays all the REDUCE input and
    output in the current session.  It is read-only.  The bottom pane
    is an input editor that supports all the standard keyboard and
    mouse-based editing facilities normally provided by your platform.
    Both panes display vertical and horizontal scroll bars when
    necessary.  Text does not wrap.  Both panes can be resized
    vertically by dragged the bottom right-hand corner.  Input text
    can always be copied from the top pane; plain text output can also
    be copied but typeset mathematical output cannot currently be
    copied in such a way that it can be re-input into REDUCE.
</p>
<p>
    You type (or paste) REDUCE input into the input editor pane, edit
    it as necessary, and then click on the <em>Send Input</em>
    button, which sends the input to REDUCE and echos it in the top
    pane.  This clears the input editor, but you can scroll through
    previous input (entered via the input editor) using the
    <em>Earlier Input</em> and <em>Later Input</em> buttons.
    Scrolling to input later than the last previous input clears the
    input editor pane back to its state before you started scrolling.
</p>
<p>
    When keyboard focus is in the input editor pane, the following
    keyboard shortcuts are active:
</p>
<table class="table">
    <thead>
        <tr>
            <th>Keyboard Shortcut</th>
            <th>Action</th>
        </tr>
    </thead>
    <tbody>
        <tr>
            <td><em>Control+Enter</em></td>
            <td>Send Input (auto-terminated)</td>
        </tr>
        <tr>
            <td><em>Control+Shift+Enter</em></td>
            <td>Send Input (not auto-terminated)</td>
        </tr>
        <tr>
            <td><em>Control+UpArrow</em></td>
            <td>Earlier Input</td>
        </tr>
        <tr>
            <td><em>Control+DownArrow</em></td>
            <td>Later Input</td>
        </tr>
    </tbody>
</table>
<p>where <em>Enter</em> is the <em>Return</em> or <em>Enter</em>
    key and <em>UpArrow</em> / <em>DownArrow</em> are the cursor up /
    down keys, respectively.
</p>
<p>Sending input to REDUCE strips any trailing white space and
    normally auto-terminates it by adding a semicolon if there was no
    final terminator.  However, holding the <em>Shift</em> key while
    clicking on the <em>Send Input</em> button or pressing
    <em>Control+Enter</em> suppresses auto-termination.
</p>
<p>You can edit previous input recalled into the input editor as
    necessary and then send it to REDUCE.  Input can be multi-line, in
    which case REDUCE processes all the lines together.  The
    <em>Send Input</em> action is disabled until REDUCE is running,
    and the <em>Earlier Input</em> and <em>Later Input</em> actions
    are disabled unless there is earlier or later input, respectively.
</p>

<h2 id="ViewMenu">The View Menu</h2>
<p>
    The <em>View</em> menu provides the following items:</p>
<h3>Typeset Maths</h3>
<p>
    Selecting this item causes Web REDUCE to display algebraic-mode
    mathematical output more-or-less as it would be typeset.  Output
    display will be significantly faster when Typeset Maths is turned
    off.  Typeset output should appear very similar to that displayed
    by the CSL REDUCE GUI and <a href="https://www.texmacs.org/">TeXmacs</a>
    since it is generated by the same REDUCE code, although in Web
    REDUCE it is displayed using the
    <a href="https://www.mathjax.org">MathJax</a> JavaScript library.
    Right-clicking on typeset math output pops up the MathJax context
    menu.
</p>
<h3>Centre Typeset Maths</h3>
<p>
    Selecting this item causes Web REDUCE to display typeset maths
    centred horizontally; otherwise it is left justified.
</p>

<h2 id="TemplatesMenu">The Templates Menu</h2>

<p>
    The <em>Templates</em> menu facilitates construction of structured
    expressions and statements whose syntax might not be immediately
    obvious, especially to a novice.  The template dialogues all
    provide hyperlinks to the key sections of the HTML version of the
    REDUCE Manual, which open in a new tab in your web browser.  The
    dialogues all provide two buttons that apply the filled-in
    template: the <em>Edit</em> button inserts the template output
    into the input editor at the current cursor position, replacing
    any selected text; the <em>Evaluate</em> button sends the template
    output directly to REDUCE for evaluation, adding a terminator just
    as the <em>Send Input</em> button does.  These buttons also close
    the dialogue.  To close a template dialogue explicitly, click on
    the <em>Close</em> button.
</p>
<p>
    If the template represents an operator with a primary operand then
    this defaults to <em>ws</em>, which is convenient for simple
    interactive calculations, but it can be changed to anything.  The
    templates provide some minimal input validation: for example, if
    an element must be an explicit number (rather than a variable that
    must evaluate to a number), the template will check this and
    report an error immediately an inappropriate character is entered.
    The template checks that all input has been provided that is
    required for valid REDUCE syntax.
</p>
<p>
    Templates remember their previous input, but clicking on the
    <em>Reset</em> button resets them to their initial state when Web
    REDUCE was first started.
</p>
<p>
    These templates are intended only for creating simple structures,
    but they can form the basis for arbitrarily complex structures if
    they are entered into the input editor for further editing.  The
    fields of expression templates display minimal formatting intended
    to hint at how such an expression would normally be typeset.
</p>
<p>
    The <em>Templates</em> menu provides the following items:
</p>
<h3>Derivative...</h3>
<p>This template supports (partial) differentiation involving up to
    three independent variables, each to arbitrary order.  The orders
    must be explicit positive integers and the total order
    automatically updates to reflect the number of independent
    variables and their orders.  If an order is omitted then it
    defaults to 1.  At least one independent variable is required but
    others are optional.  The dependent variable defaults to
    <em>ws</em> and the first independent variable defaults to
    <em>x</em>, but both can be changed.
</p>
<h3>Integral...</h3>
<p>This template supports both indefinite and definite integration: if
    both limits are omitted then the integral is indefinite; if both
    limits are specified then the integral is definite.  The integrand
    defaults to <em>ws</em> and the integration variable defaults
    to <em>x</em>, but both can be changed.</p>
<p>By default, the template provides a single integral, but if you
    enter another integration variable in a box to the right of the
    primary integration variable then an additional integral appears
    wrapping the previous integral, thus supporting double and triple
    integrals.  Matching &int; and <em>d</em> symbol
    pairs have the same colour (blue, green or red) to facilitate
    adding limits to the right &int; symbol.
</p>

<h2 id="FunctionsMenu">The Functions Menu</h2>

<p>
    The <em>Functions</em> menu facilitates access to some of the
    mathematical functions provided by REDUCE via dialogue boxes
    similar to those provided by the <em>Templates</em> menu.  The
    function dialogues all provide hyperlinks to the key sections of
    the HTML version of the REDUCE Manual, which open in a new tab in
    your web browser.  Hover over a function name to pop up a tooltip
    that gives a hint at its definition, which often uses linearlized
    mathematical notation similar to LaTeX (but without any
    backslashes).
</p>
<p>
    The function dialogue boxes provide a grid of function
    templates.  Click on the radio button to the left of the
    function you want to use.  The templates display the conventional
    notation used for the functions but with editable text fields
    holding the function arguments.  The default arguments are
    either <em>ws</em>, where this seems appropriate, or the
    conventional variable names.
</p>
<p>
    The <em>Functions</em> menu provides the following items:
</p>
<h3>Exp, Log, Power, etc...</h3>
<p>
    This provides the exponential function, various logarithms, power
    and roots (surds or radicals), factorial and binomial
    coefficients, and the <em>hypot</em> and <em>atan<sub>2</sub></em>
    functions.
</p>

<h2 id="HelpMenu">The Help Menu</h2>

<p>
    The <em>Help</em> menu provides the following items, which all
    open in a new browser tab:
</p>
<h3>Web REDUCE User Guide</h3>
<p>
    This document.
</p>
<h3>REDUCE Manual</h3>
<p>
    The HTML version  of the REDUCE Manual.
</p>
<h3>About Run-REDUCE</h3>
<p>
    Information about Web REDUCE, including its limitations.
</p>

<address>Francis Wright, July 2021</address>
</div><!-- opened in begin-body.php -->
<?php include '../include/footer.php'; ?>
</body>
</html>

D web/htdocs/web-reduce/about.html => web/htdocs/web-reduce/about.html +0 -27
@@ 1,27 0,0 @@
<!DOCTYPE html>

<html lang="en" xmlns="http://www.w3.org/1999/xhtml">
<head>
    <meta charset="utf-8" />
    <title>About Web REDUCE</title>
    <link href="StyleSheet.css" rel="stylesheet" type="text/css" />
</head>
<body>
    <h1>About Web REDUCE</h1>
    <h2>Purpose</h2>
    <p>Web REDUCE runs as an app in your web browser and does not need any installation. It is intended primarily as a demonstration of REDUCE appropriate for simple interactive experimentation. It is not intended for heavy-duty problem solving (although you can use it however you want). </p>
    <h2>Limitations</h2>
    <p>
        Web REDUCE will be a little slower than conventional REDUCE and there may occasionally be a noticeable pause while the REDUCE engine downloads. It does not support the standard REDUCE file access commands <a href="/manual-lookup.php?File%20Handling%20Commands"><code>in</code>, <code>out</code> or <code>shut</code></a>. Nor does it support compiling or loading user modules or packages. It does, however, provide all the standard REDUCE packages, which either autoload as usual or can be loaded explicitly with the <a href="/manual-lookup.php?User%20Contributed%20Packages"><code>load_package</code></a> command. Web REDUCE does not provide any input prompts, unlike conventional REDUCE. This limits the usefulness of the standard REDUCE commands <a href="/manual-lookup.php?Referencing%20Previous%20Results"><code>ws</code> and <code>input</code></a>, which work but you have to count inputs yourself! In principle, the standard REDUCE command <a href="/manual-lookup.php?Referencing%20Previous%20Results"><code>display</code></a> should help, but 
		it doesn't work.
        User queries do not work, so Web REDUCE sets <code><a href="/manual-lookup.php?Interactive%20File%20Control">off int</a></code> by default. Some of these limitations may get removed at some future date.</p>
    <p>
        You need a recent web browser to run Web REDUCE, preferably the latest version. It may not run on mobile devices.</p>
    <h2>What is it?</h2>
    <p>
        Web REDUCE consists of a graphical user interface (GUI) implemented using HTML, CSS and JavaScript that runs a Wasm (<a href="https://webassembly.org/">WebAssembly</a>) version of the REDUCE engine by Arthur Norman and Avery Laird, which is CSL REDUCE compiled to WebAssembly using <a href="https://emscripten.org/">Emscripten</a>. See <a href="https://sourceforge.net/p/reduce-algebra/code/HEAD/tree/trunk/csl/new-embedded/for-emscripten/">SourceForge</a> for details of how to build this version of REDUCE, which consists of two files, <code>reduce.web.js</code> and <code>reduce.web.wasm</code>. The web worker interface to the Wasm REDUCE engine uses code developed by Arthur Norman and Avery Laird. The Web REDUCE GUI is modelled on the <a href="https://fjwright.github.io/Run-REDUCE/">Run-REDUCE</a> GUI for conventional REDUCE, which itself is loosely based on the CSL REDUCE GUI by Arthur Norman.</p>
    <p>
        Typeset mathematics is output using LaTeX syntax generated by the REDUCE <code>tmprint</code> package and rendered by the <a href="https://www.mathjax.org/">MathJax</a> JavaScript library, which is also used elsewhere on the REDUCE web site.</p>
    <address>Francis Wright, July 2021</address>
</body>
</html>

A web/htdocs/web-reduce/about.php => web/htdocs/web-reduce/about.php +79 -0
@@ 0,0 1,79 @@
<?php
$page_title = 'About Web REDUCE';
$header_title = 'About Web REDUCE';
include '../include/begin-head.php';
include '../include/begin-body.php';
?>
  <h2>Purpose</h2>
  <p>Web REDUCE runs as an app in your web browser and does not need
      any installation. It is intended primarily as a demonstration of
      REDUCE appropriate for simple interactive experimentation. It is
      not intended for heavy-duty problem solving (although you can
      use it however you want).</p>
  <h2>Limitations</h2>
  <p>
      Web REDUCE will be a little slower than conventional REDUCE and
      there may occasionally be a noticeable pause while the REDUCE
      engine downloads. It does not support the standard REDUCE file
      access commands
      <a href="/manual-lookup.php?File%20Handling%20Commands"><code>in</code>, <code>out</code>
      or <code>shut</code></a>. Nor does it support compiling or
      loading user modules or packages. It does, however, provide all
      the standard REDUCE packages, which either autoload as usual or
      can be loaded explicitly with the
      <a href="/manual-lookup.php?User%20Contributed%20Packages"><code>load_package</code></a>
      command.</p>
  <p>
      However, a lot of JavaScript runs asynchronously, which means
      that a single REDUCE input of the form</p>
  <pre><code>statementA; statementB;</code></pre>
  <p><strong>may</strong> not execute <code>statementA</code> before <code>statementB</code>.
      Therefore, it is not advisable to include more than one
      statement in the same input.  This <strong>may</strong> only be
      a problem when <code>statementA</code> involves <code>load_package</code>.
      For example, the single input</p>
  <pre><code>load_package trigd; atan2d(y,x);</code></pre>
  <p>does not work, but it works as two separate inputs.</p>
  <p>
      Web REDUCE does not provide any input prompts, unlike
      conventional REDUCE. This limits the usefulness of the standard
      REDUCE commands <a href="/manual-lookup.php?Referencing%20Previous%20Results"><code>ws</code>
      and <code>input</code></a>, which work but you have to count
      inputs yourself! In principle, the standard REDUCE command
      <a href="/manual-lookup.php?Referencing%20Previous%20Results"><code>display</code></a>
      should help, but it doesn't work.  User queries do not work, so
      Web REDUCE sets <code><a href="/manual-lookup.php?Interactive%20File%20Control">off
      int</a></code> by default. Some of these limitations may get
      removed at some future date.</p>
  <p>
      Web REDUCE cannot run any external programs, so facilities that
      rely on this do not work, in particular plotting.
  <p>
    You need a recent web browser to run Web REDUCE, preferably the
    latest version. It may not run on mobile devices.</p>
  <h2>What is it?</h2>
  <p>
    Web REDUCE consists of a graphical user interface (GUI)
    implemented using HTML, CSS and JavaScript that runs a Wasm
    (<a href="https://webassembly.org/">WebAssembly</a>) version of
    the REDUCE engine by Arthur Norman and Avery Laird, which is CSL
    REDUCE compiled to WebAssembly using <a href="https://emscripten.org/">Emscripten</a>. See
      <a href="https://sourceforge.net/p/reduce-algebra/code/HEAD/tree/trunk/csl/new-embedded/for-emscripten/">SourceForge</a>
    for details of how to build this version of REDUCE, which consists
    of two files, <code>reduce.web.js</code>
    and <code>reduce.web.wasm</code>. The web worker interface to the
    Wasm REDUCE engine uses code developed by Arthur Norman and Avery
    Laird. The Web REDUCE GUI is modelled on
    the <a href="https://fjwright.github.io/Run-REDUCE/">Run-REDUCE</a>
    GUI for conventional REDUCE, which itself is loosely based on the
    CSL REDUCE GUI by Arthur Norman.</p>
  <p>
    Typeset mathematics is output using LaTeX syntax generated by the
    REDUCE <code>tmprint</code> package and rendered by
    the <a href="https://www.mathjax.org/">MathJax</a> JavaScript
    library, which is also used elsewhere on the REDUCE web site.</p>
  <address>Francis Wright, July 2021</address>
</div><!-- opened in begin-body.php -->
<?php include '../include/footer.php'; ?>
</body>
</html>

M web/htdocs/web-reduce/index.php => web/htdocs/web-reduce/index.php +3 -3
@@ 11,7 11,7 @@ include '../include/begin-head.php';
 #OutputDiv {
     border: medium black solid;
     height: 25em;
     resize: both;
     resize: vertical;
     overflow: auto;
 }



@@ 94,8 94,8 @@ include '../include/begin-body.php';
                    <a class="nav-link dropdown-toggle" href="#" id="HelpMenuLink" role="button" data-bs-toggle="dropdown" aria-expanded="false">Help
                    </a>
                    <ul class="dropdown-menu" aria-labelledby="HelpMenuLink">
                        <li><a class="dropdown-item" href="about.html" target="_blank" title="Opens in a new tab.">About Web REDUCE</a></li>
                        <li><a class="dropdown-item disabled" href="#">Web REDUCE User Guide</a></li>
                        <li><a class="dropdown-item" href="about.php" target="_blank" title="Opens in a new tab.">About Web REDUCE</a></li>
                        <li><a class="dropdown-item" href="UserGuide.php" target="_blank" title="Opens in a new tab.">Web REDUCE User Guide</a></li>
                        <li><a class="dropdown-item" href="/manual/manual.html" target="_blank" title="Opens in a new tab.">REDUCE Manual</a></li>
                    </ul>
                </li>