calcu.~pas

《Kylix程序设计》一书中附带的例程源代码

unit Calcu;

interface

uses
  SysUtils, Types, Classes, Stack;

type
  TOperandsType = array [ 1 .. 4 ] of Integer;
  TPermutationType = array [ 1 .. 4 ] of Char;
  TOperatorsType = array [ 2 .. 4 ] of Char;
  TFlagsType = array [ 2 .. 4 ] of Integer;
  TPostfixExpType = array [ 1 .. 7 ] of Char;

  TCalcu = class( TStack )
  private
    FSolved: Boolean;
    FFlags: TFlagsType;
    FOperators: TOperatorsType;
    FOperands: TOperandsType;
    FPermutation: TPermutationType;
    FPostfixExp: TPostfixExpType;
  protected
    FPrefixExpList: TStringList;
  public
    constructor Create( A: array of Integer );
    procedure Compute();
    function IsSolved(): Boolean;
    function GetPrefixExpList(): TStringList;
    destructor Destroy();
  private
    function DoCompute(): Boolean;
    procedure DoSpecialOps();
    procedure DoSpecialPos();
    procedure DoSpecialPermutation();
    procedure SortIncrementally();
    procedure GenFirstPermutation();
    function GenNextPermutation(): Boolean;
    procedure GenFirstPostfixPos();
    function GenNextPostfixPos(): Boolean;
    procedure GenFirstPostfixOps();
    function GenNextPostfixOps(): Boolean;
    procedure GenPostfixExp();
    function GenPrefixExp(): string;
  end;

implementation

{ TCalcu }

/////////////////////////////////////////////////////////////
// function TCalcu.DoCompute: Boolean;
//
// If the result is about 24, return true, otherwise return false.
// Note: The operator '/' may get an real.
//
function TCalcu.DoCompute: Boolean;
var
  a, b, c: Real;
  i, j: Integer;
begin
  Clear();
  j := 1;
  for i := 1 to 7 do
  begin
    case FPostfixExp[ i ] of
      '+':
      begin
        Pop( c );
        Pop( b );
        a := b + c;
        Push( a );
      end;
      '-':
      begin
        Pop( c );
        Pop( b );
        a := b - c;
        Push( a );
      end;
      '*':
      begin
        Pop( c );
        Pop( b );
        a := b * c;
        Push( a );
      end;
      '/':
      begin
        Pop( c );
        Pop( b );
        if c = 0 then
        begin
          Result := false;
          exit;
        end;
        a := b / c;
        Push( a );
      end;
      else
      begin
        Push( FOperands[ j ] );
        Inc( j );
      end;
    end;
  end;
  Pop( a );
  if Abs( a - 24.0 ) < 1e-7 then
  begin
    if not FSolved then FSolved := true;
    Result := true;
  end
  else
  begin
    Result := false;
  end;
end;

/////////////////////////////////////////////////////////////
// constructor TCalcu.Create(A: array of Integer);
//
// Constructor function
//
constructor TCalcu.Create(A: array of Integer);
var
  i: Integer;
begin
  inherited Create();
  if Length( A ) < 4 then
  begin
    // Error.
    Free();
  end
  else
  begin
    for i := 1 to 4 do
    begin
      FOperands[ i ] := A[ i - 1 ];
      case FOperands[ i ] of
        1: FPermutation[ i ] := 'A';
        2 .. 9: FPermutation[ i ] := Chr( FOperands[ i ] + 48 );
        10: FPermutation[ i ] := 'T';
        11: FPermutation[ i ] := 'J';
        12: FPermutation[ i ] := 'Q';
        13: FPermutation[ i ] := 'K';
      end;
    end;
    FSolved := false;
    FPrefixExpList := TStringList.Create();
  end;
end;

/////////////////////////////////////////////////////////////
// destructor TCalcu.Destroy;
//
// destructor function
//
destructor TCalcu.Destroy;
begin
  if Assigned( FPrefixExpList ) then
  begin
    FPrefixExpList.Free();
    FPrefixExpList := nil;
  end;
  inherited;
end;

/////////////////////////////////////////////////////////////
// procedure TCalcu.GenFirstPermutation;
//
// Get the first permutation. It must be 'abcd', a < b < c < d.
// 'a, b, c, d' in [ 2..10, J, Q, K, A ]
//
procedure TCalcu.GenFirstPermutation;
begin
  SortIncrementally();
end;

/////////////////////////////////////////////////////////////
// procedure TCalcu.GenFirstPostfixOps;
//
// Get the first postfix operators. It must be '+, +, +'.
// The array 'FOperators' presents operators inserted.
// Insert the operator 'FOperators[i]' after the operand 'FFlags[i]'.
//
procedure TCalcu.GenFirstPostfixOps;
var
  i: Integer;
begin
  for i := 2 to 4 do
  begin
    FOperators[ i ] := '+';
  end;
end;

/////////////////////////////////////////////////////////////
// procedure TCalcu.GenFirstPostfixPos;
//
// Get the first postfix position. It must be 'abcd+++'.
// The array 'FFlags' presents where operators insert.
// At the very beginning, flags are the largest '4, 4, 4'.
// This means that all operators are be insereted at last.
//
procedure TCalcu.GenFirstPostfixPos;
var
  i: Integer;
begin
  for i := 2 to 4 do
  begin
    FFlags[ i ] := 4;
  end;
end;

/////////////////////////////////////////////////////////////
// function TCalcu.GenNextPermutation: Boolean;
//
// Generate the next permutation, according to the directory order.
// If no next permutation exists, return false otherwise return true.
//
function TCalcu.GenNextPermutation: Boolean;
var
  i, j, k: Integer;
  MaxI, MaxJ: Integer;
  n: Integer;
  c: Char;
  Operands: TOperandsType;
  Permutation: TPermutationType;
begin
  MaxI := 0;
  MaxJ := 0;
  // Get the max i where FOperands[i-1] < FOperands[i], and let 'MaxI := i'
  for i := 2 to 4 do
  begin
    if FOperands[ i - 1 ] < FOperands[ i ] then
      MaxI := i;
  end;
  // All permutations have been listed?
  if not ( MaxI = 0 ) then  // No, some permutation(s) remain(s).
  begin
    // Get the max J where FOperands[ MaxI - 1 ] < FOperands[ j ], and let MaxJ := J
    for j := MaxI to 4 do
    begin
      if FOperands[ maxI - 1 ] < FOperands[ j ] then
        MaxJ := j;
    end;
    // Swap element( MaxI - 1 ) and element( MaxJ )
    n := FOperands[ MaxI - 1 ];
    FOperands[ MaxI - 1 ] := FOperands[ MaxJ ];
    FOperands[ MaxJ ] := n;
    c := FPermutation[ MaxI - 1 ];
    FPermutation[ MaxI - 1 ] := FPermutation[ MaxJ ];
    FPermutation[ MaxJ ] := c;
    // Reverse the order of elements after the element( MaxI - 1 )
    i := 0;
    for k := MaxI to 4 do
    begin
      Operands[ k ] := FOperands[ 4 - i ];
      Permutation[ k ] := FPermutation[ 4 - i ];
      Inc( i );
    end;
    for k := MaxI to 4 do
    begin
      FOperands[ k ] := Operands[ k ];
      FPermutation[ k ] := Permutation[ k ];
    end;
    Result := true;
  end
  else
    Result := false;
end;

/////////////////////////////////////////////////////////////
// function TCalcu.GenNextPostfixOps: Boolean;
//
// Get the next postfix operators.
// If the current flag is '+, +, +', and the next is '+, +, -'.
//
function TCalcu.GenNextPostfixOps: Boolean;
var
  i: Integer;
begin
  for i := 4 downto 2 do
  begin
    case FOperators[ i ] of
      '+':
      begin
        FOperators[ i ] := '-';
        Result := true;
        exit;
      end;
      '-':
      begin
        FOperators[ i ] := '*';
        Result := true;
        exit;
      end;
      '*':
      begin
        FOperators[ i ] := '/';
        Result := true;
        exit;
      end;
      '/':
      begin
        FOperators[ i ] := '+';
        Result := true;
      end;
    end;
  end;
  Result := false;
end;

/////////////////////////////////////////////////////////////
// function TCalcu.GenNextPostfixPos: Boolean;
//
// Get the next postfix position.
// If the current position is '4, 4, 4', then the next is '3, 4, 4'.
// If the current position is '3, 4, 4', then the next is '2, 4, 4'.
// If the current position is '2, 4, 4', then the next is '3, 3, 4'.
// If the current position is '3, 3, 4', then the next is '2, 3, 4'.
// If the current position is '2, 3, 4', then return false.
//
function TCalcu.GenNextPostfixPos: Boolean;
var
  i, j: Integer;
begin
  for i := 2 to 4 do
  begin
    if FFlags[ i ] > i then
    begin
      Dec( FFlags[ i ] );
      for j := 2 to i - 1 do
        FFlags[ j ] := FFlags[ i ];
      Result := true;
      exit;
    end;
  end;
  Result := false;
end;

/////////////////////////////////////////////////////////////
// procedure TCalcu.GenPostfixExp;
//
// Get the next postfix operators.
// If 'FFlags[2]' is 'i', then copy first 'i' elements
// from 'FPermutation' to 'FPostfixExp'. Then insert the operator.
// If 'FFlags[3]' is 'i', then copy the successor 'FFlags[3]-FFlags[2]' elements
// from 'FPermutation' to 'FPostfixExp'. THen insert the operator.
//
procedure TCalcu.GenPostfixExp;
var
  i, j, k, n: Integer;
begin
  k := 1;
  for i := 2 to 4 do
  begin
    if i = 2 then
      n := 0
    else
      n := FFlags[ i - 1 ];
    for j := 1 to FFlags[ i ] - n do
    begin
      FPostfixExp[ k ] := FPermutation[ n + j ];
      Inc( k );
    end;
    FPostfixExp[ k ] := FOperators[ i ];
    Inc( k );
  end;
end;

/////////////////////////////////////////////////////////////
// function TCalcu.GenPrefixExp: string;
//
// Get the next prefix expressions.
// We must first generate the binary tree of the the postfix expression,
// and then traverse the binary tree to get its inorder expression.
//
// This function contains three subrountines:
// 1. function CreateBinaryTree(): PBinaryTreeType;
// 2. function GetPriority( c: Char ): Integer;
// 3. function TraverseInOrder( p: PBinaryTreeType ): string;
//
function TCalcu.GenPrefixExp: string;
type
  TLeafType = set of Char;
  PBinaryTreeType = ^TBinaryTreeType;
  TBinaryTreeType = record
    Data: Char;
    Parent: PBinaryTreeType;
    LChild: PBinaryTreeType;
    RChild: PBinaryTreeType;
  end;

const
  LeafSet: TLeafType = [ '2' .. '9', 'T', 'J', 'Q', 'K', 'A' ];

/////////////////////////////////////////////////////////////
// function CreateBinaryTree(): PBinaryTreeType;
//
// Create the binary tree.
// The local variable 'BinaryTree' points to the root,
// while 'p' and 'q' points to the previous and the current node, seperately.
//
function CreateBinaryTree(): PBinaryTreeType;
var
  i: Integer;
  BinaryTree, p, q: PBinaryTreeType;
  ToRight: Boolean;
begin
  New( BinaryTree );
  p := BinaryTree;
  p^.Data := FPostfixExp[ 7 ];
  p^.Parent := BinaryTree;
  p^.LChild := nil;
  p^.RChild := nil;
  ToRight := true;
  for i := 6 downto 1 do
  begin
    New( q );
    q^.Data := FPostfixExp[ i ];
    q^.Parent := nil;
    q^.LChild := nil;
    q^.RChild := nil;
    if ToRight then
    begin
      p^.RChild := q;
      q^.Parent := p;
      if q^.Data in LeafSet then
        ToRight := false;
    end
    else
    begin
      while Assigned( p^.LChild ) do
        p := p^.Parent;
      p^.LChild := q;
      q^.Parent := p;
      if not ( q^.Data in LeafSet ) then
        ToRight := true;
    end;
    if not ( q^.Data in LeafSet ) then
      p := q;
  end;
  Result := BinaryTree;
end;

/////////////////////////////////////////////////////////////
// function GetPriority( c: Char ): Integer;
//
// Use the priority of the operators to determine
//  whether insert braces or not.
//
function GetPriority( c: Char ): Integer;
begin
  case c of
    '+', '-': Result := 1;
    '*', '/': Result := 2;
    else      Result := 3;
  end;
end;

/////////////////////////////////////////////////////////////
// function TraverseInOrder( p: PBinaryTreeType ): string;
//
// Traverse the binary tree inorder.
//
function TraverseInOrder( p: PBinaryTreeType ): string;
var
  s: string;
begin
  if not Assigned( p ) then
    Result := s;
  if Assigned( p^.LChild ) then
  begin
    if GetPriority( p^.LChild^.Data ) < GetPriority( p^.Data ) then
    begin
      s := '(' + TraverseInOrder( p^.LChild ) + ')';
    end
    else
    begin
      s := TraverseInOrder( p^.LChild );
    end;
  end;
  Result := s + p^.Data;
  if Assigned( p^.RChild ) then
  begin
    if ( ( p^.Data = '/' ) and not ( p^.RChild^.Data in LeafSet ) )
      or ( ( p^.Data = '-' ) and ( GetPriority( p^.RChild^.Data ) = GetPriority( p^.Data ) ) )
      or ( GetPriority( p^.RChild^.Data ) < GetPriority( p^.Data ) ) then
    begin
      s := '(' + TraverseInOrder( p^.RChild ) + ')';
    end
    else
    begin
      s := TraverseInOrder( p^.RChild );
    end;
    Result := Result + s;
  end;
end;

var
  BinaryTree: PBinaryTreeType;

begin
  BinaryTree := CreateBinaryTree();
  Result := TraverseInOrder( BinaryTree );
end;

/////////////////////////////////////////////////////////////
// function TCalcu.GetPrefixExpList: TStringList;
//
// Return the field 'FPrefixExpList', a TStringList object.
//
function TCalcu.GetPrefixExpList: TStringList;
begin
  Result := FPrefixExpList;
end;

/////////////////////////////////////////////////////////////
// function TCalcu.IsSolved: Boolean;
//
// Return the field 'FSolved', a Boolean variable.
// If the problem has been solved, then 'FSolved' is true.
//
function TCalcu.IsSolved: Boolean;
begin
  Result := FSolved;
end;

/////////////////////////////////////////////////////////////
// procedure TCalcu.SortIncrementally;
//
// Sort four cards Incrementally.
// The result is the first permutation.
//
procedure TCalcu.SortIncrementally;
var
  i, j: Integer;
  n: Integer;
  c: Char;
begin
  for i := 1 to 3 do
  begin
    for j := i+1 to 4 do
    begin
      if FOperands[ i ] > FOperands[ j ] then
      begin
        n := FOperands[ i ];
        FOperands[ i ] := FOperands[ j ];
        FOperands[ j ] := n;
        c := FPermutation[ i ];
        FPermutation[ i ] := FPermutation[ j ];
        FPermutation[ j ] := c;
      end;
    end;
  end;
end;

/////////////////////////////////////////////////////////////
// function TCalcu.Compute: Boolean;
//
// Generate first permutation, judge it,
// then for other permutations, do the same.
//
procedure TCalcu.Compute;
var
  i : Integer;
begin
  GenFirstPermutation();
  DoSpecialPermutation();
  while GenNextPermutation() do
  begin
    DoSpecialPermutation();
  end;
end;

/////////////////////////////////////////////////////////////
// procedure TCalcu.DoSpecialPermutation;
//
// Generate first postfix position, judge it,
// then for other postfix positions, do the same.
// Called by 'Compute'.
//
procedure TCalcu.DoSpecialPermutation;
begin
  GenFirstPostfixPos();
  DoSpecialPos();
  while GenNextPostfixPos() do
  begin
    DoSpecialPos();
  end;
end;

/////////////////////////////////////////////////////////////
// procedure TCalcu.DoSpecialPos;
//
// Generate first postfix operator series, judge it,
// then for other postfix operator series, do the same.
// Called by 'DoSpecialPermutation'.
//
procedure TCalcu.DoSpecialPos;
begin
  GenFirstPostfixOps();
  DoSpecialOps();
  while GenNextPostfixOps() do
  begin
    DoSpecialOps();
  end;
end;

/////////////////////////////////////////////////////////////
// procedure TCalcu.DoSpecialOps;
//
// Call 'GenPostfixExp' to generate a postfix expression,
// and then call 'DoCompute' to judge.
// If the result is true,
// then insert the prefix expression to 'FPrefixExpList'.
//
procedure TCalcu.DoSpecialOps;
var
  s: string;
begin
 GenPostfixExp();
  if DoCompute() then
  begin
    s := GenPrefixExp();
    // Version 2 begins
    FPrefixExpList.Sorted := true;
    FPrefixExpList.Duplicates := dupIgnore;
    // ersion 2 end.
    FPrefixExpList.Add( s );
  end;
end;

end.