home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / PASCAL / 30TURUTL / PC-CALC.PAS < prev    next >
Pascal/Delphi Source File  |  1985-05-30  |  20KB  |  598 lines
  1. program calc(input, output);
  2. {*R+}
  3.  
  4.    const
  5.      ls_len = 20;
  6.      F1 = 59;
  7.      F2 = 60;
  8.      F3 = 61;
  9.      AF3 = 106;
  10.      SF3 = 86;
  11.      F4 = 62;
  12.      AF4 = 107;
  13.      SF4 = 87;
  14.      F10 = 68;
  15.      Clear_Mem = 14;
  16.      End_Key = 79;
  17.      c_op1_row = 20;
  18.      c_op1_col = 50;
  19.      c_op2_row = 22;
  20.      c_op2_col = 50;
  21.      c_opcode_row = 21;
  22.      c_opcode_col = 75;
  23.  
  24.    type
  25.      calc = set of char;
  26.      ls = string[ls_len];
  27.  
  28.    var
  29.      op1_col, op2_col, col : integer;
  30.      m_row, m_col : array[1..6] of integer;
  31.      done, valid, control : boolean;
  32.      prev_op,prev_char,chr_value,scan_code,blank,hold_char : char;
  33.      value_string, blank_ls, zero : ls;
  34.      memory_values : array[1..6] of ls;
  35.      operand, total : real;
  36.      operators,numbers,plus_or_minus : calc;
  37.      memory_registers : calc;
  38.      i : integer;
  39.      result : record
  40.               ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  41.               end;
  42.  
  43.   procedure getchar(var char_value, scan_code : char);
  44.      begin
  45.        result.ax := $0000;
  46.        intr($16, result);
  47.        scan_code := chr(ord(hi(result.ax)));
  48.        char_value := chr(ord(lo(result.ax)));
  49.      end; {getchar}
  50.  
  51.   procedure locate(row, col : integer);
  52.      begin
  53.        row := row + 1;
  54.        col := col + 1;
  55.        GotoXY(col, row);
  56.      end; {locate}
  57.  
  58.   procedure wrtattrib(row, col : integer;
  59.                       char_value : char;
  60.                       background, foreground : integer);
  61.      begin
  62.        GotoXY(col + 1, row + 1);
  63.        TextColor(foreground);
  64.        TextBackground(background);
  65.        write(char_value);
  66.      end; {wrtattrib}
  67.  
  68. {The following procedure emits a 440-Hertz beep for 1/4 of a second}
  69.   procedure beep;
  70.      begin
  71.        Sound(440);
  72.        Delay(250);
  73.        NoSound;
  74.      end; {beep}
  75.  
  76.    procedure Clear_Memory;
  77.      forward;
  78.    procedure initialize;
  79.      var m_var : ls;
  80.  
  81.      procedure m_set_up(m_var : ls; row, col, ls_len : integer);
  82.        var
  83.         i : integer;
  84.        begin {m_set_up}
  85.          for i := 1 to length(m_var) do
  86.            wrtattrib(row, col + (i - 1), m_var[i], Blue, Yellow);
  87.           col := col + 3;
  88.           wrtattrib(row, col, blank, Blue, Yellow);
  89.           for i:= 1 to ls_len-1 do
  90.             begin
  91.               col := col + 1;
  92.               wrtattrib(row, col, blank, Blue, Yellow);
  93.             end;
  94.        end; {m_set_up}
  95.  
  96.      procedure set_up_2(row, col, len : integer;
  97.                         background, foreground : integer);
  98.        var col_save : integer;
  99.        begin {set_up_2}
  100.           col_save := col;
  101.           col := col + 1;
  102.           for i:= 1 to len do
  103.             begin
  104.               wrtattrib(row, col, blank, background, foreground);
  105.               col := col + 1;
  106.             end;
  107.          col := col_save;
  108.          locate(row,col);
  109.        end; {set_up_2}
  110.  
  111.      procedure set_up_3(st : ls);
  112.        begin {set_up_3}
  113.         set_up_2(WhereY - 1, WhereX, Length(st), Blue, Yellow);
  114.         write(st);
  115.        end; {set_up_3}
  116.  
  117.      begin {initialize}
  118.        done := false;
  119.        operators := ['+','-','*','/','='];
  120.        plus_or_minus := ['+','-'];
  121.        numbers := ['0'..'9','.'];
  122.        memory_registers := ['1'..'6'];
  123.        blank := ' ';
  124.        prev_op:=chr(255);  {initialize prev_op}
  125.        prev_char:=chr(255);  {initialize prev_char}
  126.        TextMode(3);        {CO80}
  127.        GotoXY(34, 1);
  128.        write('PC Calculator');
  129.        op1_col := c_op1_col - 1;
  130.        op2_col := c_op2_col - 1;
  131.        zero := '0.00000000';
  132.        blank_ls := ' ';
  133.  
  134.        for i:= 1 to ls_len + 1 do
  135.          begin
  136.            wrtattrib(c_op1_row, op1_col, blank, Blue, Yellow);
  137.            op1_col := op1_col + 1;
  138.          end;
  139.        op1_col := c_op1_col;
  140.  
  141.        for i:= 1 to ls_len + 1 do
  142.          begin
  143.            wrtattrib(c_op2_row, op2_col, blank, Blue, Yellow);
  144.            op2_col := op2_col + 1;
  145.          end;
  146.        op2_col := c_op2_col;
  147.  
  148.        wrtattrib(c_opcode_row, c_opcode_col, blank, Blue, Yellow);
  149.  
  150.        m_row[1] := 2; m_row[2] := 2; m_row[3] :=2;
  151.        m_row[4] := 4; m_row[5] := 4; m_row[6] :=4;
  152.        m_col[1] := 2; m_col[2] := 28; m_col[3] :=54;
  153.        m_col[4] := 2; m_col[5] := 28; m_col[6] :=54;
  154.        m_var := 'M1'; m_set_up(m_var, m_row[1], m_col[1], ls_len);
  155.        m_var := 'M2'; m_set_up(m_var, m_row[2], m_col[2], ls_len);
  156.        m_var := 'M3'; m_set_up(m_var, m_row[3], m_col[3], ls_len);
  157.        m_var := 'M4'; m_set_up(m_var, m_row[4], m_col[4], ls_len);
  158.        m_var := 'M5'; m_set_up(m_var, m_row[5], m_col[5], ls_len);
  159.        m_var := 'M6'; m_set_up(m_var, m_row[6], m_col[6], ls_len);
  160.        Clear_Memory;
  161.  
  162.        GotoXY(25, 25);
  163.        write('*** Esc to terminate program ***');
  164.  
  165.         set_up_2(14, 3, 3, LightGray, Red);
  166.         write(' ', chr(17), '--  ');
  167.         set_up_3('Clear Memory ');
  168.         set_up_2(WhereY - 1, WhereX + 2, 3, LightGray, Red);
  169.         write(' End ');
  170.         set_up_3('  Clear');
  171.         set_up_2(16, 3, 3, LightGray, Red);
  172.         write('  F1 ');
  173.         set_up_3(' STO ');
  174.         set_up_2(WhereY - 1, WhereX + 1, 3, LightGray, Red);
  175.         write('  F2 ');
  176.         set_up_3(' RCL ');
  177.         set_up_2(18, 3, 3, LightGray, Red);
  178.         write('  F3 ');
  179.         set_up_3(' x'+ chr(253)+ ' ');
  180.         set_up_2(WhereY - 1, WhereX + 2, 3, LightGray, Red);
  181.         write(' AF3 ');
  182.         set_up_3('  ' + chr(251) + 'x ');
  183.         set_up_2(WhereY - 1, WhereX + 2, 3, LightGray, Red);
  184.         write(' SF3 ');
  185.         set_up_3('  x' + chr(252) + ' ');
  186.         set_up_2(20, 3, 3, LightGray, Red);
  187.         write('  F4 ');
  188.         set_up_3(' ' + chr(241) + '  ');
  189.         set_up_2(WhereY - 1, WhereX + 2, 3, LightGray, Red);
  190.         write(' AF4 ');
  191.         set_up_3(' ' + chr(179) + 'x' + chr(179) + ' ');
  192.         set_up_2(WhereY - 1, WhereX + 2, 3, LightGray, Red);
  193.         write(' SF4 ');
  194.         set_up_3(' 1/x ');
  195.         set_up_2(22, 3, 3, LightGray, Red);
  196.         write(' F10 ');
  197.         set_up_3('  Clear Op. ');
  198.  
  199.        locate(c_op2_row, op2_col);
  200.        for i := 1 to ls_len-1 do blank_ls := Concat(blank_ls, ' ');
  201.      end; {initialize}
  202.  
  203.    procedure format_lstring (var type_ls : ls);
  204.      var
  205.          i : integer;
  206.        chk : boolean;
  207.      begin
  208.      {remove leading blanks}
  209.      while type_ls[1] = ' ' do
  210.        delete(type_ls,1,1);
  211.  
  212.      {remove trailing zeroes after the decimal point}
  213.      i := length(type_ls);
  214.      chk := true;
  215.      while chk and (i > 0) do
  216.        begin {chk}
  217.          if type_ls[i] = '0' then delete(type_ls,i,1)
  218.            else chk := false;
  219.          i := length(type_ls);
  220.        end; {chk}
  221.      end; {format_lstring}
  222.  
  223.    procedure chk_if_valid1; {checks if first character entered is valid}
  224.      begin {chk_if_valid1}
  225.            if (chr_value in plus_or_minus) or (chr_value in numbers) then
  226.              begin {2}
  227.                valid:=true;
  228.                prev_op := '*';
  229.                prev_char := chr_value;
  230.                operand := 0;
  231.                if (chr_value in numbers) or (chr_value = '+') then
  232.                  begin
  233.                   total := 1;
  234.                   value_string := '0';
  235.                  end
  236.                  else
  237.                  begin
  238.                   total := -1;
  239.                   value_string := '0';
  240.                  end
  241.              end {2}
  242.            else
  243.            valid:=false;
  244.    end; {chk_if_valid1}
  245.  
  246.    procedure chk_if_valid2;
  247.      begin
  248.        if (chr_value in operators) or
  249.           (chr_value in numbers) or
  250.           (ord(scan_code) = F1) or
  251.           (ord(scan_code) = F2) or
  252.           (ord(scan_code) = F3) or
  253.           (ord(scan_code) = AF3) or
  254.           (ord(scan_code) = SF3) or
  255.           (ord(scan_code) = F4) or
  256.           (ord(scan_code) = AF4) or
  257.           (ord(scan_code) = SF4)
  258.           then valid := true
  259.           else valid := false;
  260.        if (prev_char in operators) and (chr_value in operators)
  261.           then valid := false;
  262.      end; {chk_if_valid2}
  263.  
  264.    procedure chk_if_valid;
  265.      begin
  266.        control := false;
  267.        if ord(scan_code) = End_Key then control := true; {End?}
  268.        if not control then
  269.           begin {control}
  270.              if ord(prev_op)=255 then chk_if_valid1
  271.             else
  272.              chk_if_valid2;
  273.           end; {control}
  274.      end; {chk_if_valid}
  275.  
  276.    procedure End_key_pressed;
  277.      begin {End key pressed}
  278.          prev_op:=chr(255);  {initialize prev_op}
  279.          prev_char:=chr(255);  {initialize prev_char}
  280.          locate(c_op1_row, op1_col);
  281.          write(blank_ls);
  282.          op2_col := c_op2_col;
  283.          locate(c_op2_row, op2_col);
  284.          write(blank_ls);
  285.          locate(c_opcode_row, c_opcode_col);
  286.          write(' ');
  287.          Clear_Memory;
  288.          locate(c_op2_row, op2_col);
  289.          value_string := '';
  290.     end; {End key pressed}
  291.  
  292.    procedure Clear_Memory;
  293.      var i : integer;
  294.          row, col : integer;
  295.      begin {Clear_Memory}
  296.      row := WhereY;
  297.      col := WhereX;
  298.      for i := 1 to 6 do
  299.        begin
  300.          memory_values[i] := zero;
  301.          locate(m_row[i],m_col[i] + 3);
  302.          write(blank_ls);
  303.          locate(m_row[i],m_col[i] + 3);
  304.          write(zero);
  305.        end; {end do}
  306.      locate(row, col);
  307.     end; {Clear_Memory}
  308.  
  309.     procedure equal_help;
  310.         begin {equal_help}
  311.           Str(total : 18 : 8, value_string);
  312.           format_lstring(value_string);
  313.           locate(c_op1_row, op1_col);
  314.           write(blank_ls);
  315.           locate(c_op1_row, op1_col);
  316.           write(value_string);
  317.     end; {equal_help}
  318.  
  319.    procedure F1_key_pressed; {store}
  320.              forward;
  321.    procedure F2_key_pressed; {RCL}
  322.              forward;
  323.    procedure Integer_Power;
  324.              forward;
  325.    procedure Equal_key_pressed;
  326.      var exit_now : boolean;
  327.      begin {Equal sign key pressed}
  328.        exit_now := false;
  329.        repeat
  330.          getchar(chr_value, scan_code);
  331.          if (chr_value in ['+', '-', '*', '/']) or
  332.               (ord(scan_code)=1) or
  333.               (ord(scan_code) = F1) or
  334.               (ord(scan_code) = F2) or
  335.               (ord(scan_code) = F3) or
  336.               (ord(scan_code) = AF3) or
  337.               (ord(scan_code) = SF3) or
  338.               (ord(scan_code) = F4) or
  339.               (ord(scan_code) = AF4) or
  340.               (ord(scan_code) = SF4) or
  341.               (ord(scan_code) = End_Key) or
  342.               (ord(scan_code) = Clear_Mem) then
  343.              else
  344.                 beep;
  345.          if ord(scan_code) = F1 then F1_key_pressed;
  346.          if ord(scan_code) = F2 then F2_key_pressed;
  347.          if ord(scan_code) = F3 then
  348.            begin
  349.              total := sqr(total);
  350.              equal_help;
  351.            end;
  352.          if ord(scan_code) = AF3 then
  353.            begin
  354.              if total >= 0 then total := sqrt(total) else beep;
  355.              equal_help;
  356.            end;
  357.          if ord(scan_code) = SF3 then
  358.            begin
  359.              Integer_Power;
  360.              equal_help;
  361.            end;
  362.          if ord(scan_code) = F4 then
  363.            begin
  364.              total := - total;
  365.              equal_help;
  366.            end;
  367.          if ord(scan_code) = AF4 then
  368.            begin
  369.              total := abs(total);
  370.              equal_help;
  371.            end;
  372.          if (ord(scan_code) = SF4) then
  373.            begin
  374.              if total <> 0 then total := 1 / total else beep;
  375.              equal_help;
  376.            end;
  377.          if (ord(scan_code) = Clear_Mem) then Clear_Memory;
  378.          if (ord(scan_code) = End_Key) then
  379.             begin
  380.               End_Key_Pressed;
  381.               exit_now := true;
  382.             end;
  383.        until (chr_value in ['+', '-', '*', '/'])
  384.               or (ord(scan_code) = 1)
  385.               or (exit_now = true);
  386.        if ord(scan_code) = 1 then done := true;
  387.        if (ord(scan_code) <> End_Key) then prev_op := chr_value;
  388.        locate(c_opcode_row, c_opcode_col);
  389.        write(chr_value); {write new operator}
  390.      end; {Equal sign key pressed}
  391.  
  392.    procedure F1_key_pressed; {STO}
  393.      var memory_index : integer;
  394.      begin {F1 pressed}
  395.        repeat
  396.          getchar(chr_value, scan_code);
  397.          if not (chr_value in memory_registers) then beep;
  398.        until (chr_value in memory_registers)
  399.               or (ord(scan_code) = 1); {Esc?}
  400.        if ord(scan_code) = 1 then done := true;
  401.        memory_index := ord(chr_value) - ord('0');
  402.        memory_values[memory_index] := value_string;
  403.        locate(m_row[memory_index],m_col[memory_index] + 3);
  404.        write(blank_ls);
  405.        locate(m_row[memory_index],m_col[memory_index] + 3);
  406.        write(memory_values[memory_index]);
  407.        locate(c_opcode_row, c_opcode_col);
  408.        write(' ');
  409.        Equal_key_pressed;
  410.      end; {STO}
  411.  
  412.    procedure F2_key_pressed; {RCL}
  413.      var memory_index : integer;
  414.          chr_value : char;
  415.      begin {F2 pressed}
  416.        repeat
  417.          getchar(chr_value, scan_code);
  418.          if not (chr_value in memory_registers) then beep;
  419.        until (chr_value in memory_registers)
  420.               or (ord(scan_code) = 1); {Esc?}
  421.        if ord(scan_code) = 1 then done := true;
  422.        memory_index := ord(chr_value) - ord('0');
  423.        value_string := memory_values[memory_index];
  424.        op2_col := c_op2_col;
  425.        locate(c_op2_row, op2_col);
  426.        write(blank_ls);
  427.        locate(c_op2_row, op2_col);
  428.        write(memory_values[memory_index]);
  429.      end; {F2 pressed}
  430.  
  431.    procedure Integer_Power;
  432.      var i, power : integer;
  433.          chr_value : char;
  434.          total_save : real;
  435.      begin {Integer_Power}
  436.        power := 0;
  437.        total_save := total;
  438.        repeat
  439.          getchar(chr_value, scan_code);
  440.          if not (chr_value in ['0'..'9', chr(13)]) then beep;
  441.          if chr_value in ['0'..'9'] then
  442.              power := power * 10 +(ord(chr_value) - ord('0'));
  443.        until (chr_value = chr(13))
  444.               or (ord(scan_code) = 1); {Esc?}
  445.        if ord(scan_code) = 1 then done := true;
  446.        if power = 0 then total := 1
  447.          else
  448.           begin
  449.             if power > 1 then
  450.               for i := 1 to power - 1 do total := total * total_save;
  451.           end;
  452.      end; {Integer_Power}
  453.  
  454.  
  455.    function command : boolean;
  456.      begin
  457.        command := false; {default}
  458.        if ord(scan_code) = 1 then command := true; {Esc?}
  459.        if ord(scan_code) = End_Key then command := true; {End?}
  460.        if ord(scan_code) =15 then command := true; {Clear_Memory}
  461.      end; {command}
  462.  
  463.    procedure do_it2;
  464.      begin
  465.        case prev_op of
  466.          '+' : total := total + operand;
  467.          '-' : total := total - operand;
  468.          '*' : total := total * operand;
  469.          '/' : total := total / operand;
  470.        end; {end case}
  471.      end; {do_it2}
  472.  
  473.    procedure do_it;
  474.      var
  475.        could_do : integer;
  476.      begin
  477.       if control and (ord(scan_code)=End_Key) then
  478.          End_key_pressed;
  479.  
  480.     if not control then
  481.           begin {not control}
  482.             if (chr_value in operators) or
  483.                (ord(scan_code) = F1) or
  484.                (ord(scan_code) = F2) or
  485.                (ord(scan_code) = F3) or
  486.                (ord(scan_code) = SF3) or
  487.                (ord(scan_code) = AF3) or
  488.                (ord(scan_code) = F4) or
  489.                (ord(scan_code) = SF4) or
  490.                (ord(scan_code) = AF4)
  491.               then
  492.                 begin {is operator}
  493.                   { convert string to real value }
  494.                   Val(value_string, operand, could_do);
  495.                 { if could_do <> 0 then beep; }
  496.                   if (prev_op in ['+', '-', '*', '/']) and
  497.                      (ord(scan_code) <> F2) then do_it2;
  498.                   if ord(scan_code) = F3 then
  499.                      begin
  500.                        total := total * total;
  501.                        prev_op := chr(0);
  502.                      end; {F3}
  503.                   if (ord(scan_code) = SF3) then
  504.                      begin
  505.                        Integer_Power;
  506.                        prev_op := chr(0);
  507.                      end; {SF3}
  508.                   if (ord(scan_code) = AF3) then
  509.                      begin
  510.                        if total >= 0 then total := sqrt(total) else beep;
  511.                        prev_op := chr(0);
  512.                      end; {AF3}
  513.                   if ord(scan_code) = F4 then
  514.                      begin
  515.                        total := - total;
  516.                        prev_op := chr(0);
  517.                      end; {F4}
  518.                   if ord(scan_code) = AF4 then
  519.                      begin
  520.                        total := abs(total);
  521.                        prev_op := chr(0);
  522.                      end; {AF4}
  523.                   if (ord(scan_code) = SF4) then
  524.                      begin
  525.                        if total <> 0 then total := 1 / total else beep;
  526.                        prev_op := chr(0);
  527.                      end; {SF4}
  528.                   equal_help;
  529.                   op2_col := c_op2_col; {reset}
  530.                   locate(c_op2_row, op2_col);
  531.                   write(blank_ls); {clear area out}
  532.                   if chr_value = '=' then Equal_key_pressed;
  533.                   if ord(scan_code) = F1 then F1_key_pressed;
  534.                   if (chr_value <> '=') and (ord(scan_code) <> F1)
  535.                      and (ord(scan_code) <> F2)
  536.                      and (ord(scan_code) <> F3)
  537.                      and (ord(scan_code) <> End_Key)
  538.                      then prev_op := chr_value;
  539.                   locate(c_op2_row, op2_col);
  540.                   value_string := '';
  541.                   if ord(scan_code) = F2 then F2_key_pressed;
  542.                 end {is operator}
  543.               else
  544.                 if length(value_string) < ls_len
  545.                    then
  546.                     value_string := concat(value_string, chr_value)
  547.                     else beep;
  548.           end; {not control}
  549.      end; {do_it}
  550.  
  551.    begin  {main program}
  552.  
  553.   { note:
  554.      Esc - terminate
  555.      End - reset
  556.                   }
  557.  
  558.      initialize;
  559.      repeat  {until (done)}
  560.        repeat  {until (ord(scan_code) <> F10)}
  561.           hold_char := prev_char; {save previous character}
  562.           prev_char := chr_value;
  563.           getchar(chr_value, scan_code);
  564.           if ord(scan_code) = Clear_mem then Clear_Memory;
  565.           if command then prev_char := hold_char; {restore}
  566.           if ord(scan_code) = 1 then done := true; {Esc pressed?}
  567.           if ord(scan_code) = F10 then
  568.             begin {F10 hit - re-set operand}
  569.               op2_col := c_op2_col;
  570.               locate(c_op2_row, c_op2_col);
  571.               write(blank_ls);
  572.               locate(c_op2_row, c_op2_col);
  573.               value_string := '';
  574.             end; {F10}
  575.        until (ord(scan_code) <> F10);
  576.        if (done = false) and (ord(scan_code) <> Clear_Mem) then
  577.           begin {done = false}
  578.               chk_if_valid;
  579.               if valid then
  580.                 begin {is valid}
  581.                   if chr_value in operators then
  582.                       locate(c_opcode_row, c_opcode_col);
  583.                   if (chr_value in operators) or
  584.                      (length(value_string) < ls_len -1) then
  585.                       write(chr_value);
  586.                   op2_col :=  op2_col + 1;
  587.                   do_it;
  588.                 end {is valid}
  589.                 else
  590.                 begin {not valid}
  591.                   valid := true; {reset valid indicator}
  592.                   beep;
  593.                end; {not valid}
  594.           end; {done = false}
  595.      until (done);
  596.      clrScr;
  597.    end.
  598.