Smart Pascal Web Version of BigFibonacci
by Felix Thompson: Y13 Age ~18
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.