
--
-- Copyright (C) 2019  <fastrgv@gmail.com>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You may read the full text of the GNU General Public License
-- at <http://www.gnu.org/licenses/>.
--




with ada.characters.handling;  use ada.characters.handling;
with ada.characters.latin_1;

with text_io; use text_io;

with  Ada.Numerics.generic_elementary_functions;


procedure rpn is 

	package math is new
		Ada.Numerics.generic_elementary_functions( long_float );
	use math;

   onepi : constant long_float := arctan(1.0)*4.0;

   deg2rad : constant long_float := onepi/180.0;
   
   rad2deg : constant long_float := 180.0/onepi;
   
   package myfloat_io is new text_io.float_io(long_float);


   type optype is 
     (data,  -- indicator of numerical, non-operator token
      plus, minus, times, divide, power,
         sin,    cos,    tan,  ln, log2,
        aSin,   aCos, aTan, Exp, sqRt
     );

   type tokentype is record op: optype; val: long_float; end record;
   
   maxstack : integer := 99;
   type stacktype is array(0..maxstack) of tokentype;
   stack : stacktype;
   top : integer := 0; -- next available position

   --global numerical accumulators:
   num, expnum : long_float := 0.0;
   frac : long_float := 1.0;
   numpending, exppending, degmode : boolean := false;
   numsign, expsign : long_float := 1.0;


   savtop, savnex : long_float := 0.0;
   ch,ch2: character;
   last: natural;
   instr: string(1..80);
   val, oldval, oldint: integer;

   subtype linerange is integer range 0..79;
   type linetype is array(linerange) of character;
   line : linetype;
   len,this  : linerange := 0;

   mem : array(0..9) of long_float := (others=>0.0);


-- resets all numerical accumulators:
procedure reset is
begin
  frac:=1.0;
  num:=0.0;  expnum:=0.0;
  numpending:=false;
  exppending:=false;
  numsign:=1.0;
  expsign:=1.0;
end reset;

-- assemble a number when ready:
procedure update is
begin
  num:=numsign*num;
  if exppending then
    expnum := expsign*expnum;
    num:=num * (10.0**expnum);
  end if;
end update;



procedure push( op: optype ) is
  toosmall : constant long_float := 1.0e-1;
  toolarge : constant long_float := 1.0e4;
begin

if( ((op=data) and numpending) or (op/=data) ) then

  if( op = data ) then
    update;
  end if;

  if( top < maxstack ) then
    stack(top).op := op;
    stack(top).val := num;
    top := top+1; --points to next available space

    if( op = data ) then
      if(abs(num)<toosmall)or(abs(num)>toolarge) then
        myfloat_io.put(num,5,9,3);
      else
        myfloat_io.put(num,9,9,0);
      end if;
      put_line("    [ stack.top:"&integer'image(top)&" ]");
      null;
    else
      put(" "&optype'image(op)&" ");
      new_line;
    end if;

    --reset accumulators
    reset;

  end if;

end if;

end push;


function pop return long_float is
begin
  if( top=0 ) then
    put_line("error: popping empty stack");
    --get_line(instr,last);
    --put_line("aborting");
    --raise program_error;
  else
    top:=top-1;
  end if;

  if( stack(top).op /= data ) then
    put_line("error in pop val");
    get_line(instr,last);
    put_line("aborting");
    raise program_error;
  end if;

  return stack(top).val;
end pop;


function pop return optype is
begin
  if( top=0 ) then
    put_line("error in pop op: popping empty stack");
    get_line(instr,last);
    put_line("aborting");
    raise program_error;
  end if;
  top:=top-1;
  if( stack(top).op = data ) then
    put_line("error in pop op");
    get_line(instr,last);
    put_line("aborting");
    raise program_error;
  end if;
  return stack(top).op;
end pop;




procedure applyOp is
  left, right : long_float;
  op : optype;
  nint, ninv : integer;
  integral, oddinv, intinv, odd : boolean;
begin
  op := pop;
  right := pop;
  case op is
    when plus =>
      left  := pop;
      num:=left+right;
      numpending:=true;
      push( data );
    when minus =>
      left  := pop;
      num:=left-right;
      numpending:=true;
      push( data );
    when times =>
      left  := pop;
      num:=left*right;
      numpending:=true;
      push( data );
    when divide =>
      left  := pop;
      num:=left/right;
      numpending:=true;
      push( data );
    when power =>
      left  := pop;

      -- this next maneuver allows [real] results
      -- even with a negative base, so long
      -- as the exponent is an integer or
      -- the reciprocal of an odd number.
      nint := integer( long_float'rounding(right) );
      integral := ( right = long_float(nint) );
      ninv := integer( long_float'rounding(1.0/right) );
      intinv := ( 1.0 / right = long_float(ninv) );
      odd := (ninv mod 2 = 1);
      oddinv := odd and intinv;
      if integral then
        num:=left**nint;
      elsif oddinv and (left<0.0) then
        num := -( (-left)**right );
      else
        num:=left**right;
      end if;

      numpending:=true;
      push( data );

--all the rest only require 1 argument
    when sqrt =>
      num:=sqrt(right);
      numpending:=true;
      push( data );
    when sin =>
      if degmode then
        num:=sin(right*deg2rad);
      else
        num:=sin(right);
      end if;
      numpending:=true;
      push( data );
    when cos =>
      if degmode then
        num:=cos(right*deg2rad);
      else
        num:=cos(right);
      end if;
      numpending:=true;
      push( data );
    when tan =>
      if degmode then
        num:=tan(right*deg2rad);
      else
        num:=tan(right);
      end if;
      numpending:=true;
      push( data );
    when asin =>
      if degmode then
        num:=rad2deg*arcsin(right);
      else
        num:=arcsin(right);
      end if;
      numpending:=true;
      push( data );
    when acos =>
      if degmode then
        num:=rad2deg*arccos(right);
      else
        num:=arccos(right);
      end if;
      numpending:=true;
      push( data );
    when atan =>
      if degmode then
        num:=rad2deg*arctan(right);
      else
        num:=arctan(right);
      end if;
      numpending:=true;
      push( data );
    when exp =>
      num:=exp(right);
      numpending:=true;
      push( data );
    when ln =>
      num:=log(right);
      numpending:=true;
      push( data );
    when log2 =>
      num:=log(right)/log(2.0);
      numpending:=true;
      push( data );
    when others =>
      put_line("error in applyOp");
      get_line(instr,last);
      put_line("aborting");
      raise program_error;
  end case;

end applyOp;


procedure get_token( line: in out linetype; len: in out linerange ) is
  ch,ch2: character;
  ord : positive_count;
  stop : boolean := false;
  bch: character := Ada.Characters.Latin_1.BS;
  dch: character := Ada.Characters.Latin_1.DEL;
begin

 len:=0;
 loop
  get_immediate(ch); --gets keybd input as typed
  ord := character'pos(ch);

  if(ord=127)or(ord=8) then -- <del> or <bs>
    if(len>0) then
      len:=len-1;
      put(bch);
    end if;
  else

    line(len):=ch;
    if(ord/=13)and(ord/=10)and(ord/=27) then
      put( ch );
    end if;
    stop := (ch in 'A'..'Z')or(ch in 'a'..'z')
          or(ord=43)or(ord=45) -- + -
	  or(ord=42)or(ord=47) -- * /
	  or(ord=94)           -- ^
	  or(ord=27)           -- <esc>
	  or(ord=10)or(ord=13); --<ret>
    if( ch = 'e' ) then 
      stop:=false; -- part of a number
    end if;
    if( (ch = 'm') or (ch = 'M') ) then
      -- still need to get memory # 0..9
      get_immediate(ch2);
      put(ch2);
      len:=len+1;
      line(len):=ch2;
    end if;
    exit when stop;
    len:=len+1;

  end if;
  
 end loop;
 if
   (ord=10)or(ord=13)or(ord=43)or(ord=45)or
   (ord=42)or(ord=47)or(ord=94)or
   (ch in 'A'..'Z') or 
   ((ch in 'a'..'z') and (ch /= 'n') )
 then
   new_line;
 end if;

 --debug output
 --new_Line;
 --put('|');
 --for l in 0..len loop
 --  put(line(l));
 --end loop;
 --put('|');
 --new_line;
 
end get_token;



procedure menu is
begin
  new_line;
  put_line("---------------- mouseless RPN calculator ---------------");
  new_line;
  put_line("Key Map:");
  put_line("            <esc>=>{quit}    <z>=>{clr}      <n>=>{CHS}");
  put_line("             <e>=>{EEX}      <E>=>{e^x}      <^>=>{x^y}");
  put_line("             <s>=>{sin}      <c>=>{cos}      <t>=>{tan}");
  put_line("             <S>=>{asin}     <C>=>{acos}     <T>=>{atan}");
  put_line("             <l>=>{ln}       <p>=>{pi}       <r>=>{sqrt}");
  put_line("             <L>=>{lg}       <D>=>{Deg}      <R>=>{Rad}*");
  put_line("             <x>=>{X:Y}      <m>=>{STO}      <M>=>{RCL}");
  new_line;
end menu;


begin --rpn(main)

  menu;

  outer:
  loop

    get_token(line, len);
    this:=0;
   
    inner: 
    loop

      ch := line(this);

      if( is_digit(ch) ) then
        val:=character'pos(ch) - character'pos('0');
      end if;
    
      case ch is

      when '+' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( plus );
       applyOp;

      when '-' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( minus );
       applyOp;

      when '*' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( times );
       applyOp;

      when '/' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( divide );
       applyOp;

      when '^' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( power );
       applyOp;

      when 'r' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( sqrt );
       applyOp;

      when 's' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( sin );
       applyOp;

      when 'c' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( cos );
       applyOp;

      when 't' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( tan );
       applyOp;

      when 'S' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( asin );
       applyOp;

      when 'C' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( acos );
       applyOp;

      when 'T' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( atan );
       applyOp;

      when 'E' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( exp );
       applyOp;

      when 'l' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( ln );
       applyOp;

      when 'L' =>
       if numpending then
         push( data ); -- enterkey is implicit here
       end if;
       push( log2 );
       applyOp;


      when '.' =>
        if exppending then
	  put_line("cannot accept long_float here");
          get_line(instr,last);
          put_line("aborting");
	  raise program_error;
	else
          numpending:=true;
          frac:=0.1;
	end if;
     
      when 'p' => --pi
        reset;
	numpending:=true;
	num:=arctan(1.0)*4.0;
	push( data );

      when 'e' =>
	exppending:=true;
 
      when 'n' => -- change sign (Negate)
        if exppending then
	  expsign:=-1.0;
	else
          numsign:=-1.0;
	end if;

      when '0'..'9' =>
        if exppending then
          expnum := expnum*10.0 + long_float(val);
	else
          numpending:=true;
          if( frac < 1.0 ) then
            num := num + long_float(val)*frac;
            frac := frac/10.0;
          else
            num := num*10.0 + long_float(val);
          end if;
	end if;
 
      when 'q'|'Q' =>  -- quit
	exit outer; --loop (quit gracefully)

      when 'D' => -- deg
        degmode:=true;
	put_line(" Degree mode");

      when 'R' => -- rad
        degmode:=false;
	put_line(" Radian mode");
	
      when 'x' => -- x:y
        savtop:=pop;
	savnex:=pop;
	num:=savtop; numpending:=true; push(data);
	num:=savnex; numpending:=true; push(data);
      
      when 'z' => -- clear
        reset;
	top:=0;
	put_line(" Clear All");

      when 'm' =>  -- STO logic
        if numpending then
          push( data ); -- enterkey is implicit here
        end if;
	this:=this+1;
        ch2:=line(this);
	reset;
        if( is_digit(ch2) and (top>0) ) then
          val:=character'pos(ch2) - character'pos('0');
	  savtop:=pop;
	  mem(val):=savtop;
	  put     (" stored Memory # "&integer'image(val));
          put_line("    [ stack.top:"&integer'image(top)&" ]");
	else
	  put(line(1));
	  raise program_error;
        end if;

      when 'M' =>  -- RCL logic
	this:=this+1;
        ch2:=line(this);
        if( is_digit(ch2) ) then
          val:=character'pos(ch2) - character'pos('0');
	  num:=mem(val); numpending:=true; push(data);
	else
	  put(line(1));
	  raise program_error;
        end if;


      when others =>
        if
	( character'pos(ch) = 13 ) or
	( character'pos(ch) = 10 ) -- unix/linux
        then -- <enter>
         if numpending then
           push( data );

	 -- this next clause upsets memory entry logic:
	 --else--2 consecutive <enter> => copy stacktop
	 --  savtop:=pop;
	 --  num:=savtop; numpending:=true; push(data);
	 --  num:=savtop; numpending:=true; push(data);
         end if;

	elsif( character'pos(ch) = 127) then --<bs>
	  if exppending then
	    oldval:=integer(expnum) mod 10;
	    expnum:=expnum-long_float(oldval);
	    expnum:=expnum/10.0;

	  elsif numpending then
 
	    if(frac<1.0) then  --frac=0.00001; num=1.2346
	      frac:=frac*10.0;      --frac=0.0001
	      oldint:=integer(num/frac); -- 12346
	      oldval:=oldint mod 10; -- 6
	      oldint:=oldint - oldval; -- 12340
	      num:=long_float(oldint)*frac; -- 1.2340
	    else
	      oldval:=integer(num) mod 10;
	      num:=num-long_float(oldval);
	      num:=num/10.0;
	    end if;

	  end if;

	elsif( character'pos(ch) = 27 ) then --<esc> => exit
	  exit outer; --loop (quit program gracefully)

	else -- quit

          put("  Msg: unhandled character: |"); put(ch); put_line("|");
	  put_line( "char'pos="&integer'image( character'pos(ch) ) );
          --get_line(instr,last);
          --put_line("aborting");
	  --raise program_error;
	  menu;

	end if;
	
      end case;
    
      exit inner when (this=len);
      this:=this+1;

    end loop inner;

  end loop outer;

end rpn;

