jvqturtle.pas

East make Tray Icon in delphi

    95:
      Result := txTextColor;
    96:
      Result := txTextFont;
    97:
      Result := txTextOut;
    98:
      Result := txTextSize;
    99:
      Result := txTurn;
    100:
      Result := txTextUnderline;
    101:
      Result := txUp;
  else
    if IsNum(Com) then
      Result := ''
    else
    if IsCol(Com) then
      Result := ''
    else
    if IsVar(Com) then
      Result := ''
    else
      Result := txUser(Com);
  end;
end;

procedure TJvTurtle.DoRepaintRequest;
begin
  if Assigned(FOnRepaintRequest) then
    FOnRepaintRequest(Self);
end;

function TJvTurtle.GetCol(var Col: TColor): Boolean;
var
  Token, Msg: string;
  Num: Integer;
begin
  Result := False;
  if GetToken(Token) then
    if Token = '=' then
    begin
      Result := True;
      if NPop(Msg, Num) then
        Col := Num
      else
        Result := False;
    end
    else
      try
        Col := StringToColor(Variant(Token));
        Result := True;
      except
        Result := False;
      end;
end;

function TJvTurtle.InVariables(Token: string; var Num: Integer): Boolean;
var
  N: Integer;
begin
  Result := FVariables.Find(Token, N);
  if Result then
    Num := Integer(FVariables.Objects[N]);
end;

function TJvTurtle.GetNum(var Num: Integer): Boolean;
var
  Token, Msg: string;
begin
  Result := False;
  if GetToken(Token) then
    if Token = '=' then
      Result := NPop(Msg, Num)
    else
    if InVariables(Token, Num) then
      Result := True
    else
      try
        Num := StrToInt(Token);
        Result := True;
      except
        Result := False;
      end;
end;

function TJvTurtle.GetTex(var Tex: string): Boolean;
begin
  Tex := '';
  Result := False;
  while (FIP <= FIPMax) and (FScript[FIP] <> '"') do
    Inc(FIP);
  if FIP > FIPMax then
    Exit;
  Inc(FIP);
  while (FIP <= FIPMax) and (FScript[FIP] <> '"') do
  begin
    Tex := Tex + FScript[FIP];
    Inc(FIP);
  end;
  if FIP > FIPMax then
    Exit;
  Inc(FIP);
  Result := Tex <> '';
end;

function TJvTurtle.GetToken(var Token: string): Boolean;
const
  Delimiters = [' ', Tab, Cr, Lf];
begin
  Token := '';
  while (FIP <= FIPMax) and (FScript[FIP] in Delimiters) do
    Inc(FIP);
  while (FIP <= FIPMax) and not (FScript[FIP] in Delimiters) do
  begin
    Token := Token + FScript[FIP];
    Inc(FIP);
  end;
  Token := LowerCase(Token);
  Result := Token <> '';
end;

function TJvTurtle.GetWidth: Integer;
begin
  if Assigned(FCanvas) then
    Result := FCanvas.Pen.Width
  else
    Result := 1;
end;

function TJvTurtle.Interpret(var ALine, ACol: Integer; const S: TStrings): string;
var
  I: Integer;
  Msg: string;
begin
  ALine := 0;
  ACol := 0;
  Result := RsErrorCanvasNotAssigned;
  if not Assigned(FCanvas) then
    Exit;
  txDefault;
  FScript := S.Text;
  FSP := 0;
  FIP := 1;
  FIPMax := Length(FScript);
  if FIPMax > 0 then
  begin
    FVariables.Clear;
    repeat
      Msg := DoCom;
    until Msg <> '';
    Result := Msg;
    ALine := 0;
    ACol := 0;
    for I := 1 to FIP-1 do
    begin
      Inc(ACol);
      if (FScript[I] = Cr) or (FScript[I] = Lf) then
      begin
        Inc(ALine);
        ACol := 0;
      end;
      if (I > 1) and (FScript[I] = Lf) and (FScript[I-1] = Cr) then
      begin
        Dec(ALine);
        Dec(ACol);
      end;
    end;
    if ACol < 0 then
      ACol := 0;
  end
  else
    Result := RsEmptyScript;
end;

procedure TJvTurtle.DoGo(Dest: TPoint);
begin
  Canvas.MoveTo(Position.X, Position.Y);
  if PenDown then
    Canvas.LineTo(Dest.X, Dest.Y)
  else
    Canvas.MoveTo(Dest.X, Dest.Y);
  Position := Dest;
end;

procedure TJvTurtle.Turn(AAngle: Real);
begin
  Heading := Heading + AAngle;
end;

procedure TJvTurtle.MoveBackward(ADistance: Real);
var
  RAngle: Real;
  dX, dY: Real;
  NewPoint: TPoint;
begin
  if not Assigned(FCanvas) then
    Exit;
  RAngle := Heading * 2 * Pi / 360;
  dX := ADistance * Cos(RAngle);
  dY := ADistance * Sin(RAngle);
  NewPoint := Point(Variant(Position.X - dX), Variant(Position.Y + dY));
  DoGo(NewPoint);
end;

procedure TJvTurtle.MoveForward(ADistance: Real);
var
  RAngle: Real;
  dX, dY: Real;
  NewPoint: TPoint;
begin
  if not Assigned(FCanvas) then
    Exit;
  RAngle := Heading * 2 * Pi / 360;
  dX := ADistance * Cos(RAngle);
  dY := ADistance * Sin(RAngle);
  NewPoint := Point(Variant(Position.X + dX), Variant(Position.Y - dY));
  DoGo(NewPoint);
end;

function TJvTurtle.Pop(var Num: Integer): Boolean;
begin
  Result := FSP > 0;
  if Result then
  begin
    Dec(FSP);
    Num := FStack[FSP];
  end;
end;

function TJvTurtle.Push(Num: Integer): Boolean;
begin
  try
    if FSP >= Length(FStack) then
      SetLength(FStack, Length(FStack) + 256);
    FStack[FSP] := Num;
    Inc(FSP);
    Result := True;
  except
    Result := False;
  end;
end;

procedure TJvTurtle.Right(AAngle: Real);
begin
  Heading := Heading - AAngle;
end;

procedure TJvTurtle.SetArea(const Value: TRect);
begin
  FArea := Value;
end;

procedure TJvTurtle.SetCanvas(const Value: TCanvas);
begin
  FCanvas := Value;
end;

procedure TJvTurtle.SetHeading(const Value: Real);
begin
  FHeading := Value;
end;

procedure TJvTurtle.SetMark(const Value: TPoint);
begin
  FMark := Value;
end;

procedure TJvTurtle.SetOnRepaintRequest(const Value: TNotifyEvent);
begin
  FOnRepaintRequest := Value;
end;

procedure TJvTurtle.SetPenDown(const Value: Boolean);
begin
  FPenDown := Value;
end;

procedure TJvTurtle.SetPosition(const Value: TPoint);
begin
  FPosition := Value;
end;

procedure TJvTurtle.SetPenWidth(const Value: Integer);
begin
  if Assigned(FCanvas) then
    FCanvas.Pen.Width := Value;
end;

function TJvTurtle.StrToCopyMode(var Cm: TCopyMode; S: string): Boolean;
type
  TMapper = record
    Name: PChar;
    Val: TCopyMode;
  end;
const
  // sorted for binary search
  Mapper: array [0..14] of TMapper =
   (
    (Name: 'cmblackness';   Val: cmBlackness),
    (Name: 'cmdstinvert';   Val: cmDstInvert),
    (Name: 'cmmergecopy';   Val: cmMergeCopy),
    (Name: 'cmmergepaint';  Val: cmMergePaint),
    (Name: 'cmnotsrccopy';  Val: cmNotSrcCopy),
    (Name: 'cmnotsrcerase'; Val: cmNotSrcErase),
    (Name: 'cmpatcopy';     Val: cmPatCopy),
    (Name: 'cmpatinvert';   Val: cmPatInvert),
    (Name: 'cmpatpaint';    Val: cmPatPaint),
    (Name: 'cmscrpaint';    Val: cmSrcPaint),
    (Name: 'cmsrcand';      Val: cmSrcAnd),
    (Name: 'cmsrccopy';     Val: cmSrcCopy),
    (Name: 'cmsrcerase';    Val: cmSrcErase),
    (Name: 'cmsrcinvert';   Val: cmSrcInvert),
    (Name: 'cmwhiteness';   Val: cmWhiteness)
   );
var
  Lo, Mid, Hi: Integer;
begin
  Lo := Low(Mapper);
  Hi := High(Mapper)+1;
  repeat
    Mid := Lo + (Hi - Lo) div 2;
    if S > Mapper[Mid].Name then
      Lo := Mid+1
    else
      Hi := Mid;
  until Lo >= Hi;
  Result := (Hi <= High(Mapper)) and (S = Mapper[Hi].Name);
  if Result then
    Cm := Mapper[Mid].Val;
end;

function TJvTurtle.StrToPenMode(var Pm: TPenMode; S: string): Boolean;
type
  TMapper = record
    Name: PChar;
    Val: TPenMode;
  end;
const
  // sorted for binary search
  Mapper: array [0..15] of TMapper =
   (
    (Name: 'pmblack';       Val: pmBlack),
    (Name: 'pmcopy';        Val: pmCopy),
    (Name: 'pmmask';        Val: pmMask),
    (Name: 'pmmasknotpen';  Val: pmMaskNotPen),
    (Name: 'pmmaskpennot';  Val: pmMaskPenNot),
    (Name: 'pmmerge';       Val: pmMerge),
    (Name: 'pmmergenotpen'; Val: pmMergeNotPen),
    (Name: 'pmmergepennot'; Val: pmMergePenNot),
    (Name: 'pmnop';         Val: pmNop),
    (Name: 'pmnot';         Val: pmNot),
    (Name: 'pmnotcopy';     Val: pmNotCopy),
    (Name: 'pmnotmask';     Val: pmNotMask),
    (Name: 'pmnotmerge';    Val: pmNotMerge),
    (Name: 'pmnotxor';      Val: pmNotXor),
    (Name: 'pmwhite';       Val: pmWhite),
    (Name: 'pmxor';         Val: pmXor)
   );
var
  Lo, Mid, Hi: Integer;
begin
  Lo := Low(Mapper);
  Hi := High(Mapper)+1;
  repeat
    Mid := Lo + (Hi - Lo) div 2;
    if S > Mapper[Mid].Name then
      Lo := Mid+1
    else
      Hi := Mid;
  until Lo >= Hi;
  Result := (Hi <= High(Mapper)) and (S = Mapper[Hi].Name);
  if Result then
    Pm := Mapper[Mid].Val;
end;

procedure TJvTurtle.TextRotate(X, Y, Angle: Integer; AText: string;
  AFont: TFont);

begin
  if AText = '' then
    Exit; 
  TextOutAngle(Canvas, Angle, X, Y, AText);  
end;

function TJvTurtle.txAngle: string;
var
  X: Integer;
begin
  if GetNum(X) then
  begin
    SetHeading(X);
    Result := '';
  end
  else
    Result := Format(RsInvalidIntegerIns, ['angle']);
end;

function TJvTurtle.txArea: string;
var
  X1, Y1, X2, Y2: Integer;
begin
  if GetNum(X1) and GetNum(Y1) and GetNum(X2) and GetNum(Y2) then
  begin
    Area := Rect(X1, Y1, X2, Y2);
    Result := '';
  end
  else
    Result := Format(RsInvalidIntegerIns, ['area']);
end;

function TJvTurtle.txBrushColor: string;
var
  Col: TColor;
begin
  if GetCol(Col) then
  begin
    Canvas.Brush.Color := Col;
    Result := '';
  end
  else
    Result := Format(RsInvalidColorIns, ['brushcolor']);
end;

function TJvTurtle.txBsClear: string;
begin
  Canvas.Brush.Style := bsClear;
  Result := '';
end;

function TJvTurtle.txBsSolid: string;
begin
  Canvas.Brush.Style := bsSolid;
  Result := '';
end;

function TJvTurtle.txCopy: string;
var
  X, Y: Integer;
begin
  X := Position.X;
  Y := Position.Y;
  with Area do
    Canvas.CopyRect(Rect(X, Y, X + Right - Left, Y + Bottom - Top), Canvas, Area);
  Result := '';
end;

function TJvTurtle.txCopyMode: string;
var
  S: string;
  CopyMode: TCopyMode;
begin
  Result := RsInvalidCopyMode;
  if GetToken(S) then
  begin
    S := 'cm' + S;
    if StrToCopyMode(CopyMode, S) then
    begin
      Canvas.CopyMode := CopyMode;
      Result := '';
    end;
  end;
end;

function TJvTurtle.txDown: string;
begin
  PenDown := True;
  Result := '';
end;

function TJvTurtle.txEllipse: string;
var
  X2, Y2: Integer;
begin
  if GetNum(X2) and GetNum(Y2) then
  begin
    X2 := Position.X + X2;
    Y2 := Position.Y + Y2;
    Canvas.Ellipse(Position.X, Position.Y, X2, Y2);
    Result := '';
  end
  else
    Result := Format(RsInvalidIntegerIns, ['ellipse']);
end;

function TJvTurtle.txGo: string;
var
  X: Integer;
begin
  if GetNum(X) then
  begin
    MoveForward(X);
    Result := '';
  end
  else
    Result := Format(RsInvalidIntegerIns, ['go']);
end;

function TJvTurtle.txGoMark: string;
begin
  DoGo(Mark);
  Result := '';
end;

function TJvTurtle.txTurn: string;
var
  X: Integer;
begin
  if GetNum(X) then
  begin
    Turn(X);
    Result := '';
  end
  else
    Result := Format(RsInvalidIntegerIns, ['turn']);
end;

function TJvTurtle.txLeft: string;
var
  X: Integer;
begin
  if GetNum(X) then
  begin
    Heading := Heading + X;
    Result := '';
  end
  else
    Result := Format(RsInvalidIntegerIns, ['left']);
end;

function TJvTurtle.txRight: string;
var
  X: Integer;
begin
  if GetNum(X) then
  begin
    Heading := Heading - X;
    Result := '';
  end
  else
    Result := Format(RsInvalidIntegerIns, ['right']);
end;

function TJvTurtle.txMark: string;
begin
  Mark := Position;
  Result := '';
end;

function TJvTurtle.txPenColor: string;
var
  Col: TColor;
begin
  if GetCol(Col) then
  begin
    Canvas.Pen.Color := Col;
    Result := '';
  end
  else
    Result := Format(RsInvalidColorIns, ['pencolor']);
end;

function TJvTurtle.txPenMode: string;
var
  S: string;
  PenMode: TPenMode;
begin
  Result := RsInvalidPenMode;
  if GetToken(S) then