jvturtle.pas

East make Tray Icon in delphi

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
  begin
    S := 'pm' + S;
    if StrToPenMode(PenMode, S) then
    begin
      Canvas.Pen.Mode := PenMode;
      Result := '';
    end;
  end;
end;

function TJvTurtle.txPenSize: string;
var
  Width: Integer;
begin
  if GetNum(Width) then
  begin
    Canvas.Pen.Width := Width;
    Result := '';
  end
  else
    Result := Format(RsInvalidIntegerIns, ['pensize']);
end;

function TJvTurtle.txPos: string;
var
  X, Y: Integer;
begin
  if GetNum(X) and GetNum(Y) then
  begin
    Position := Point(X, Y);
    Result := '';
  end
  else
    Result := Format(RsInvalidIntegerIns, ['pos']);
end;

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

function TJvTurtle.txText: string;
var
  S: string;
  A: Integer;
begin
  if GetTex(S) then
  begin
    A := Variant(Heading);
    TextRotate(Position.X, Position.Y, A, S, Canvas.Font);
    Result := '';
    DoRepaintRequest;
  end
  else
    Result := Format(RsInvalidTextIns, ['text']);
end;

function TJvTurtle.txTextBold: string;
begin
  Canvas.Font.Style := Canvas.Font.Style + [fsBold];
  Result := '';
end;

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

function TJvTurtle.txTextFont: string;
var
  FontName: string;
begin
  if GetTex(FontName) then
  begin
    Canvas.Font.Name := FontName;
    Result := '';
  end
  else
    Result := RsMissingFontname;
end;

function TJvTurtle.txTextItalic: string;
begin
  Canvas.Font.Style := Canvas.Font.Style + [fsItalic];
  Result := '';
end;

function TJvTurtle.txTextNormal: string;
begin
  Canvas.Font.Style := [];
  Result := '';
end;

function TJvTurtle.txTextSize: string;
var
  FontSize: Integer;
begin
  if GetNum(FontSize) then
  begin
    Canvas.Font.Size := FontSize;
    Result := '';
  end
  else
    Result := Format(RsInvalidIntegerIns, ['fontsize']);
end;

function TJvTurtle.txTextUnderline: string;
begin
  Canvas.Font.Style := Canvas.Font.Style + [fsUnderline];
  Result := '';
end;

function TJvTurtle.txUp: string;
begin
  PenDown := False;
  Result := '';
end;

function TJvTurtle.txDo: string;
var
  Num: Integer;
begin
  if GetNum(Num) then
  begin
    Result := RsStackOverflow;
    if Push(FIP) then
      if not Push(Num) then
        Result := '';
  end
  else
    Result := Format(RsNumberExpectedIns, ['do']);
end;

function TJvTurtle.txLoop: string;
var
  Reps, Ret: Integer;
begin
  if Pop(Reps) and Pop(Ret) then
  begin
    Dec(Reps);
    if Reps <> 0 then
    begin
      FIP := Ret;
      Push(Ret);
      Push(Reps);
    end;
    Result := '';
  end
  else
    Result := RsStackUnderflow;
end;

{$IFDEF VCL}
function TJvTurtle.txFlood: string;
var
  X, Y, XF, YF: Integer;
begin
  if GetNum(X) and GetNum(Y) then
  begin
    XF := Position.X + X;
    YF := Position.Y + Y;
    Canvas.FloodFill(XF, YF, Canvas.Pixels[XF, YF], fsSurface);
    Result := '';
  end
  else
    Result := Format(RsInvalidIntegerIns, ['flood']);
end;
{$ENDIF VCL}

procedure TJvTurtle.SetOnRequestBackground(const Value: TRequestBackgroundEvent);
begin
  FOnRequestBackground := Value;
end;

procedure TJvTurtle.DoRequestBackground;
begin
  if Assigned(FOnRequestBackground) then
    FOnRequestBackground(Self, FBackground);
end;

function TJvTurtle.txBackground: string;
var
  Name: string;
begin
  if GetTex(Name) then
  begin
    FBackground := Name;
    DoRequestBackground;
    Result := '';
  end
  else
    Result := Format(RsInvalidTextIns, ['background']);
end;

function TJvTurtle.txTextOut: string;
var
  Text: string;
begin
  if GetTex(Text) then
  begin
    Canvas.TextOut(Position.X, Position.Y, Text);
    Result := '';
  end
  else
    Result := Format(RsInvalidTextIns, ['text']);
end;

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

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

function TJvTurtle.txGoMarkAngle: string;
begin
  Heading := FAngleMark;
  Result := '';
end;

function TJvTurtle.txMarkAngle: string;
begin
  FAngleMark := Variant(Heading);
  Result := '';
end;

function TJvTurtle.IsCol(Tex: string): Boolean;
var
  Msg: string;
begin
  try
    Result := NPush(Msg, StringToColor(Tex));
  except
    Result := False;
  end;
end;

function TJvTurtle.IsNum(Tex: string): Boolean;
var
  Msg: string;
begin
  try
    Result := NPush(Msg, StrToInt(Tex));
  except
    Result := False;
  end;
end;

function TJvTurtle.NPop(var Msg: string; var Num: Integer): Boolean;
begin
  Result := FNSP > 0;
  if Result then
  begin
    Dec(FNSP);
    Num := FNStack[FNSP];
    Msg := '';
  end
  else
    Msg := RsNumberStackUnderflow;
end;

function TJvTurtle.NPush(var Msg: string; Num: Integer): Boolean;
begin
  try
    if FNSP >= Length(FNStack) then
      SetLength(FNStack, Length(FNStack) + 256);
    FNStack[FNSP] := Num;
    Inc(FNSP);
    Msg := '';
    Result := True;
  except
    Msg := RsNumberStackOverflow;
    Result := False;
  end;
end;

function TJvTurtle.txComment: string;
begin
  while (FIP <= FIPMax) and (FScript[FIP] <> '}') do
    Inc(FIP);
  if FIP <= FIPMax then
  begin
    Inc(FIP);
    Result := '';
  end
  else
    Result := RsMissingAfterComment;
end;
(*)

function TJvTurtle.SkipBlock: Boolean;
begin
  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
    Inc(FIP);
  if FIP > FIPMax then
    Exit;
  Inc(FIP);
  Result := True;
end;
(*)

procedure TJvTurtle.SetOnRequestImageSize(const Value: TRequestImageSizeEvent);
begin
  FOnRequestImageSize := Value;
end;

function TJvTurtle.DoRequestImageSize: Boolean;
begin
  Result := Assigned(FOnRequestImageSize);
  if Result then
    FOnRequestImageSize(Self, FImageRect);
end;

function TJvTurtle.txGoBottom: string;
var
  NewPoint: TPoint;
begin
  if DoRequestImageSize then
  begin
    NewPoint := Point(Position.X, FImageRect.Bottom);
    DoGo(NewPoint);
    Result := '';
  end
  else
    Result := Format(RsErrorIns, ['gobottom']);
end;

function TJvTurtle.txGoLeft: string;
var
  NewPoint: TPoint;
begin
  if DoRequestImageSize then
  begin
    NewPoint := Point(FImageRect.Left, Position.Y);
    DoGo(NewPoint);
    Result := '';
  end
  else
    Result := Format(RsErrorIns, ['goleft']);
end;

function TJvTurtle.txGoRight: string;
var
  NewPoint: TPoint;
begin
  if DoRequestImageSize then
  begin
    NewPoint := Point(FImageRect.Right, Position.Y);
    DoGo(NewPoint);
    Result := '';
  end
  else
    Result := Format(RsErrorIns, ['goright']);
end;

function TJvTurtle.txGoTop: string;
var
  NewPoint: TPoint;
begin
  if DoRequestImageSize then
  begin
    NewPoint := Point(Position.X, FImageRect.Top);
    DoGo(NewPoint);
    Result := '';
  end
  else
    Result := Format(RsErrorIns, ['gotop']);
end;

function TJvTurtle.txDiv: string;
var
  A, B: Integer;
begin
  if NPop(Result, B) and NPop(Result, A) then
    if B <> 0 then
      NPush(Result, A div B)
    else
      Result := RsDivisionByZero;
end;

function TJvTurtle.txDrop: string;
var
  A: Integer;
begin
  NPop(Result, A);
end;

function TJvTurtle.txDup: string;
var
  A: Integer;
begin
  if NPop(Result, A) then
  begin
    NPush(Result, A);
    NPush(Result, A);
  end;
end;

function TJvTurtle.txMul: string;
var
  A, B: Integer;
begin
  if NPop(Result, B) and NPop(Result, A) then
    NPush(Result, A * B);
end;

function TJvTurtle.txSub: string;
var
  A, B: Integer;
begin
  if NPop(Result, B) and NPop(Result, A) then
    NPush(Result, A - B);
end;

function TJvTurtle.txAdd: string;
var
  A, B: Integer;
begin
  if NPop(Result, B) and NPop(Result, A) then
    NPush(Result, A + B);
end;

function TJvTurtle.txGoCenter: string;
var
  CX, CY: Integer;
begin
  if DoRequestImageSize then
  begin
    CX := (FImageRect.Right - FImageRect.Left) div 2;
    CY := (FImageRect.Bottom - FImageRect.Top) div 2;
    DoGo(Point(CX, CY));
    Result := '';
  end
  else
    Result := Format(RsErrorIns, ['gocenter']);
end;

function TJvTurtle.txDiamond: string;
var
  I, X: Integer;
  OldDown: Boolean;
begin
  Result := Format(RsInvalidIntegerIns, ['diamond']);
  if GetNum(X) then
  begin
    OldDown := PenDown;
    PenDown := True;
    Turn(45);
    for I := 1 to 4 do
    begin
      MoveForward(X);
      Turn(-90);
    end;
    Turn(-45);
    PenDown := OldDown;
    Result := '';
  end;
end;

function TJvTurtle.txCurve: string;
var
  Pts: array [0..3] of TPoint;
  I: Integer;
begin
  if GetNum(Pts[1].X) and GetNum(Pts[1].Y) and
    GetNum(Pts[2].X) and GetNum(Pts[2].Y) and
    GetNum(Pts[3].X) and GetNum(Pts[3].Y) then
  begin
    Pts[0].X := Position.X;
    Pts[0].Y := Position.Y;
    for I := 1 to 3 do
    begin
      Pts[I].X := Position.X + Pts[I].X;
      Pts[I].Y := Position.Y + Pts[I].Y;
    end;
    Canvas.PolyBezier(Pts);
    Position := Pts[3];
    Result := '';
  end
  else
    Result := Format(RsInvalidParameterIns, ['curve']);
end;

function TJvTurtle.txMove: string;
var
  X, Y: Integer;
begin
  if GetNum(X) and GetNum(Y) then
  begin
    Position := Point(Position.X + X, Position.Y + Y);
    Result := '';
  end
  else
    Result := Format(RsInvalidIntegerIns, ['move']);
end;

procedure TJvTurtle.SetOnRequestFilter(const Value: TRequestFilterEvent);
begin
  FOnRequestFilter := Value;
end;

procedure TJvTurtle.DoRequestFilter;
begin
  if Assigned(FOnRequestFilter) then
    FOnRequestFilter(Self, FFilter);
end;

function TJvTurtle.txFilter: string;
var
  AName: string;
begin
  if GetTex(AName) then
  begin
    FFilter := AName;
    DoRequestFilter;
    Result := '';
  end
  else
    Result := Format(RsInvalidTextIns, ['filter']);
end;