Smart Pascal Web Version of BigFibonacci

Introduction

This program, with no inputs, GoToXY or colour requirements, would convert neatly into a standard Smart Pascal console application. We used it (and several other student programs) to test our own implementation of a console.

You can change the value of the constant DIGITS to see the first Fibonacci number with that number of digits. Click on the green up arrow at the foot of the page to see the original program. If the program does not work in your current browser, try another such as Chrome. If you see no display at school, the security system might have blocked it. You can try instead this direct link to the program running on its own page. The Smart Pascal code follows the program in action.

Output

Code of Main Unit

unit uMain;
{
    Copyright (c) 2014 Felix Thompson

    Licensed under the Apache License, Version 2.0 (the "License"); you may not
    use this file except in compliance with the License, as described at
    http://www.apache.org/licenses/ and http://www.pp4s.co.uk/licenses/

    Converted to Smart Pascal for web preview by PPS 2014
}

interface

uses 
  System.Types, SmartCL.System, SmartCL.Components, SmartCL.Application,
  SmartCL.Game, SmartCL.GameApp, SmartCL.Graphics, uCrtCanvas;
type
  TCanvasProject = class(TW3CustomGameApplication)
  private
    const DIGITS = 1000;
    const DELAY = 100000;
    const SCALE_FACTOR = 2;
    const CELL_WIDTH = 5 * SCALE_FACTOR;
    const CELL_HEIGHT = 8 * SCALE_FACTOR;
    const FONT_SIZE = 9 * SCALE_FACTOR;
    const ROWS = 25;
    const COLS = 80;
    const WIDTH = COLS * CELL_WIDTH;
    const HEIGHT = ROWS * CELL_HEIGHT;
    Number2, Number1, TempStore : array [1..1000] of integer;
    CurrentNum : integer;

    Grid: TConsoleGrid;
    protected
      procedure ApplicationStarting; override;
      procedure ApplicationClosing; override;
      procedure PaintView(Canvas: TW3Canvas); override;
      procedure GoToXY(X, Y: integer);
      procedure clrscr;
      procedure ClrEOL;
      procedure textColor(colour: TConsoleColour);
      procedure textBackground(colour: TConsoleColour);
      procedure write(txt: string);
      procedure writeln(txt: string); overload;
      procedure writeln; overload;
end;

implementation

procedure TCanvasProject.ApplicationStarting;
begin
  inherited;
  Grid := new TConsoleGrid;
  Grid.Rows := ROWS;
  Grid.Cols := COLS;
  GameView.Width:= WIDTH;
  GameView.Height := HEIGHT;
  clrScr;
  Number2[1] := 1;                                         //One is loaded as the first
  CurrentNum := 1;                                        //Fibonacci number.
  repeat
    for var Count := 1 to DIGITS do
      begin                                                //The larger number is stored
        TempStore[Count] := Number2[Count];                //and then has the smaller added
        Number2[Count] := Number2[Count] + Number1[Count]; //to it. The smaller number is then
        Number1[Count] := TempStore[Count];                //replaced by the stored value.
      end;

    for var Count := 1 to DIGITS do
      begin                                                //Each element stores one place value.
        if Number2[Count] >= 10 then                       //If a value is larger than 10 it adds one
         begin                                             //to the next element and subtracts 10
           Number2[Count] := Number2[Count] - 10;          //from the current one.
           Number2[Count + 1] := Number2[Count + 1] + 1;
         end;
      end;

    CurrentNum := CurrentNum + 1;                          //Keeps track of the place in sequence.
  until Number2[DIGITS] <> 0;                                //Repeats until 1000th digit is filled.

  writeln('Place in sequence: ' + intToStr( CurrentNum));
  writeln('Entire number, digit by digit:');
  writeln;
  for var Count := 1 to DIGITS do
    write(intToStr(Number2[DIGITS + 1 - Count]));

  GameView.Delay := DELAY;
  GameView.StartSession(False);
end;

procedure TCanvasProject.GoToXY(X, Y: integer);
begin
  Grid.CursorX := X;
  Grid.CursorY := Y;
end;

procedure TCanvasProject.ClrScr;
begin
  Grid.ClearGrid;
  GoToXY(1, 1);
end;

procedure TCanvasProject.ClrEOL;
begin
  grid.ClearEol(Grid.CursorX, Grid.CursorY);
end;

procedure TCanvasProject.textColor(colour: TConsoleColour);
begin
  Grid.TextColour := colour;
end;

procedure TCanvasProject.textBackground(colour: TConsoleColour);
begin
  Grid.BackgroundColour := colour;
end;

procedure TCanvasProject.write(txt: string);
begin
  Grid.write(txt);
end;

procedure TCanvasProject.writeln(txt : string);
begin
  Grid.write(txt);
  Grid.CursorX := 1;
  Grid.CursorY := Grid.CursorY + 1;
end;

procedure TCanvasProject.writeln;
begin
  Grid.CursorY := Grid.CursorY + 1;
end;


procedure TCanvasProject.ApplicationClosing;
begin
  GameView.EndSession;
  Grid.Destroy;
  inherited;
end;

procedure TCanvasProject.PaintView(Canvas: TW3Canvas);

  procedure PaintGrid;
  begin
    Canvas.Font :=  IntToStr(FONT_SIZE) +'px Lucida Console';
    var currentChar: TCharacter;
    for var x := 1 to COLS do
      for var y := 1 to ROWS do
        begin
          currentChar := Grid.getCharacters[x, y];
          SetTextColor(currentChar.TextBackGroundColour, Canvas);
          Canvas.FillRect((x - 1) * CELL_WIDTH, ((y - 1) * CELL_HEIGHT) + 2, CELL_WIDTH, CELL_HEIGHT);
          SetTextColor(currentChar.TextColour, Canvas);
          Canvas.FillText(currentChar.Letter, (x - 1) * CELL_WIDTH, y * CELL_HEIGHT);
        end;
  end;

begin
  PaintGrid;
end;

end.

Code of Crt Unit

unit uCrtCanvas;

interface

uses 
  SmartCL.System, System.Colors, SmartCL.Graphics;

type
  TConsoleColour = (black, blue, green, cyan, red, magenta, brown, lightgray,
                    darkgray, lightblue, lightgreen, lightcyan, lightred, lightmagenta, yellow, white);

  TCharacter = record
    Letter: string = ' ';
    TextColour: TConsoleColour = white;
    TextBackgroundColour = black;
  end;

  TCharacters = array[1..80, 1..25] of TCharacter;

  TConsoleGrid = class
  private
    FTextColour: TConsoleColour = black;
    FBackgroundColour: TConsoleColour = white;
    FCursorX: integer = 1;
    FCursorY: integer = 1;
    FRows: integer = 25;
    FCols: integer = 80;
    FCharacters: TCharacters;
  public
    procedure setCharacters(Char: TCharacters);
    function getCharacters: TCharacters;
    procedure SetCursorX(newX: integer);
    procedure SetCursorY(newY: integer);
    procedure SetXY(newRec: TCharacter; X, Y: integer);
    function GetXY(X, Y: integer): TCharacter;
    procedure write(txt: string);
    procedure ClearEOL(startX, clearY: integer);
    procedure ClearCell(clearX, clearY: integer);
    procedure ClearGrid;
    property TextColour: TConsoleColour read FTextColour write FTextColour;
    property BackgroundColour: TConsoleColour read FBackgroundColour write FBackgroundColour;
    property CursorX: integer read FCursorX write SetCursorX;
    property CursorY: integer read FCursorY write SetCursorY;
    property Cols: integer read FCols write FCols;
    property Rows: integer read FRows write FRows;
  end;

procedure SetTextColor(colour: TConsoleColour; Canvas : TW3Canvas);

implementation

procedure SetTextColor(colour: TConsoleColour; Canvas : TW3Canvas);
begin
  case colour of
    black: Canvas.FillStyle := 'black';
    white: Canvas.FillStyle := 'white';
    brown: Canvas.FillStyle := ColorToWebStr(clBrown);
    red: Canvas.FillStyle := 'red';
    magenta: Canvas.FillStyle := ColorToWebStr(clMagenta);
    yellow: Canvas.FillStyle := 'yellow';
    green: Canvas.FillStyle := 'green';
    cyan: Canvas.FillStyle := ColorToWebStr(clCyan);
    blue: Canvas.FillStyle := 'blue';
    lightgray: Canvas.FillStyle := ColorToWebStr(clLightGray);
    darkgray: Canvas.FillStyle := ColorToWebStr(clDarkGray);
    lightred: Canvas.FillStyle := 'rgb(250, 130, 130)';
    lightmagenta: Canvas.FillStyle := 'rgb(250, 130, 250)';
    lightgreen: Canvas.FillStyle := ColorToWebStr(clLightGreen);
    lightcyan: Canvas.FillStyle := ColorToWebStr(clLightCyan);
    lightblue: Canvas.FillStyle := 'rgb(130, 130, 250)';
  end;
end;

procedure TConsoleGrid.setCharacters(Char: TCharacters);
begin
  FCharacters := Char;
end;

function TConsoleGrid.getCharacters: TCharacters;
begin
  Result := FCharacters;
end;

procedure TConsoleGrid.SetCursorX(newX: integer);
begin
  if (newX > 0) and (newX <= Cols) then
    FCursorX := newX;
end;

procedure TConsoleGrid.SetCursorY(newY: integer);
begin
  if (newY > 0) and (newY <= Rows) then
    FCursorY := newY;
end;

procedure TConsoleGrid.SetXY(newRec: TCharacter; X, Y: integer);
begin
  if (X > 0) and (X <= Cols) and (Y > 0) and (Y <= Rows) then
    FCharacters[X, Y] := newRec;
end;

function TConsoleGrid.GetXY(X, Y: integer): TCharacter;
begin
  Result := getCharacters[X, Y];
end;

procedure TConsoleGrid.write(txt: string);
var
  tempchar: TCharacter;
begin
  for var i := 1 to length(txt) do
    begin
      tempChar.TextColour := TextColour;
      tempChar.TextBackgroundColour := BackgroundColour;
      tempChar.Letter := txt[i];
      SetXY(tempChar, CursorX, CursorY);
      if CursorX < (Cols - 1) then
        CursorX := CursorX + 1
      else
        begin
          CursorX := 1;
          CursorY := CursorY + 1;  //No scrolling yet
        end;

    end;
end;

procedure TConsoleGrid.ClearCell(clearX, clearY: integer);
var
  tempChar: TCharacter;
begin
  tempChar.TextBackgroundColour := BackGroundColour;
  tempChar.Letter := ' ';
  tempChar.TextColour := black; //Not needed
  SetXY(tempChar, clearX, clearY);
end;

procedure TConsoleGrid.ClearEOL(startX, clearY: integer);
begin
  for var x := startX to Cols do
    ClearCell(x, clearY);
end;

procedure TConsoleGrid.ClearGrid;
begin
  for var y := 1 to Rows do
    ClearEOL(1, y);
end;

end.